LDAPv3 0.1.1.0 → 0.1.2.0

raw patch · 12 files changed

+591/−75 lines, 12 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• LDAPv3.cabal +3/−2
• src/Data/ASN1.hs +17/−0
• src/LDAPv3/ASN1String.hs +6/−1
• src/LDAPv3/AttributeDescription.hs +3/−55
• src/LDAPv3/DistinguishedName.hs +8/−0
• src/LDAPv3/Message.hs +12/−10
• src/LDAPv3/OID.hs +396/−0
• src/LDAPv3/ResultCode.hs +10/−1
• src/LDAPv3/StringRepr.hs +7/−1
• test/Arbitrary.hs +16/−3
• test/main.hs +107/−2

@@ -1,5 +1,11 @@ See also http://pvp.haskell.org/faq +### 0.1.2.0++- Mark `LDAPv3.ASN1String` and `LDAPv3.StringRepr` as _trustworthy_ with respect to `SafeHaskell`+- New `LDAPv3.OID` module exposing OID types and helpers+- Expose ASN.1 `Enumerated(toEnumerated,fromEnumerated)` typeclass for accessing numeric ASN.1 `ENUMERATED` values+ ### 0.1.1.0  - Add support for _String Representation of Distinguished Names_ as per RFC4514

@@ -1,12 +1,12 @@ cabal-version:       2.2 name:                LDAPv3-version:             0.1.1.0+version:             0.1.2.0  synopsis:            Lightweight Directory Access Protocol (LDAP) version 3 license:             GPL-2.0-or-later license-file:        LICENSE author:              Herbert Valerio Riedel-copyright:           © 2018-2019 Herbert Valerio Riedel+copyright:           © 2018-2023 Herbert Valerio Riedel maintainer:          hvr@gnu.org bug-reports:         https://github.com/hvr/LDAPv3/issues category:            Network@@ -75,6 +75,7 @@   hs-source-dirs: src   exposed-modules:       LDAPv3.Message+      LDAPv3.OID       LDAPv3.StringRepr       LDAPv3.ASN1String   other-modules:

@@ -112,7 +112,19 @@  ---------------------------------------------------------------------------- +-- | Alternative 'Enum' typeclass for ASN.1 'ENUMERATED' types+--+-- In contrast to the standard 'Enum' class, this class is better suited for non-contiguous ASN.1 'ENUMERATED' mappings and doesn't concern itself with operations to generate preceding/succeding elements of the enumeration.+--+-- Its primary use of this class is to provide the numeric value mapping for the purpose of (de)serializing to and from ASN.1 encodings.+--+-- @since 0.1.2 class Enumerated x where+  -- | Decode Haskell value from numeric ASN.1 'ENUMERATED' encoding value+  --+  -- Returns 'Nothing' for undefined or out-of-bounds numeric values.+  --+  -- @since 0.1.2   toEnumerated :: Int64 -> Maybe x   default toEnumerated :: (Bounded x, Enum x) => Int64 -> Maybe x   toEnumerated i0@@ -123,14 +135,19 @@       lb = fromEnum (minBound :: x)       ub = fromEnum (maxBound :: x) +  -- | Encode Haskell value to its numeric ASN.1 'ENUMERATED' encoding value+  --+  -- @since 0.1.2   fromEnumerated :: x -> Int64   default fromEnumerated :: Enum x => x -> Int64   fromEnumerated = intCast . fromEnum +-- | Trivial identity instance instance Enumerated Int64 where   toEnumerated = Just   fromEnumerated = id +-- | Trivial identity instance instance Enumerated Int where   toEnumerated = intCastMaybe   fromEnumerated = intCast

@@ -17,9 +17,14 @@ {-# LANGUAGE DataKinds         #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE Trustworthy       #-} {-# LANGUAGE TypeOperators     #-} --- | ASN.1 String Types+-- |+-- Copyright: © Herbert Valerio Riedel 2020+-- SPDX-License-Identifier: GPL-2.0-or-later+--+-- 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. --

@@ -44,9 +44,6 @@     , r'MatchingRuleId      , OID(..)-    , p'OID-    , ts'OID-    , r'OID      , p'DescrOrOID @@ -54,12 +51,11 @@  import           Common                 hiding (Option, many, option, some, (<|>)) import           Data.ASN1+import           LDAPv3.OID             (OID(OID)) import           LDAPv3.StringRepr.Class -import qualified Data.ByteString.Char8  as BSC import qualified Data.ByteString.Short  as SBS import           Data.Char              (isDigit, toLower)-import           Data.List import           Data.Set               (Set) import qualified Data.Set               as Set import qualified Data.String            as S@@ -173,60 +169,12 @@ -- oid = descr / numericoid -- descr = keystring p'DescrOrOID :: Stream s Identity Char => Parsec s () (Either KeyString OID)-p'DescrOrOID = ((Left <$> p'KeyString) <|> (Right <$> p'OID)) <?> "oid"+p'DescrOrOID = ((Left <$> p'KeyString) <|> (Right <$> asParsec)) <?> "oid"  ts'DescrOrOID :: Either KeyString OID -> ShortText ts'DescrOrOID = \case   Left (KeyString s) -> s-  Right oid          -> TS.fromString (s'OID oid)--{- | Numeric Object Identifier (OID)--> numericoid = number 1*( DOT number )-> number  = DIGIT / ( LDIGIT 1*DIGIT )-> DIGIT   = %x30 / LDIGIT       ; "0"-"9"-> LDIGIT  = %x31-39             ; "1"-"9"---}-newtype OID = OID (NonEmpty Natural)-  deriving (Eq,Ord,Show,NFData)--instance Newtype OID (NonEmpty Natural)--instance ASN1 OID where-  asn1defTag _ = asn1defTag (Proxy :: Proxy OCTET_STRING)-  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--ts'OID :: OID -> ShortText-ts'OID = TS.fromString . s'OID--s'OID :: OID -> String-s'OID (OID (x:|xs)) = intercalate "." (map show (x:xs))---p'OID :: Stream s Identity Char => Parsec s () OID-p'OID = p'numericoid-  where-    -- numericoid = number 1*( DOT number )-    p'numericoid = OID <$> (p'number `sepBy1'` char '.')--    -- number  = DIGIT / ( LDIGIT 1*DIGIT )-    -- DIGIT   = %x30 / LDIGIT       ; "0"-"9"-    -- LDIGIT  = %x31-39             ; "1"-"9"-    p'number = do-      ldigit <- digit-      if ldigit == '0'-         then pure 0-         else read . (ldigit:) <$> many digit+  Right oid          -> renderShortText oid  {- | Case-insensitive string used to denote OID short names 

@@ -49,13 +49,21 @@ -- | 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)            | -- +--------+-----------------------------------------------+ --

@@ -43,8 +43,12 @@ # define MODULE_NAME LDAPv3.Message #endif --- | This module provides a pure Haskell implementation of the /Lightweight Directory Access Protocol (LDAP)/ version 3 as specified in <https://tools.ietf.org/html/rfc4511 RFC4511>.+-- |+-- Copyright: © Herbert Valerio Riedel 2019+-- SPDX-License-Identifier: GPL-2.0-or-later --+-- This module provides a pure Haskell implementation of the /Lightweight Directory Access Protocol (LDAP)/ version 3 as specified in <https://tools.ietf.org/html/rfc4511 RFC4511>.+-- -- Serializing and deserializing to and from the wire <https://en.wikipedia.org/wiki/ASN.1 ASN.1> encoding is provided via the 'Bin.Binary' instance of 'LDAPMessage'. For the purpose of implementing network clients and servers, the operations -- -- * 'Bin.encode'@@ -191,6 +195,9 @@     , CHOICE(..)     , TagK(..) +    , -- ** 'ENUMERATED' Class+      Enumerated(toEnumerated,fromEnumerated)+       -- * Unsigned integer sub-type     , UIntBounds     , UInt@@ -203,11 +210,12 @@ import           Data.Int.Subtypes import           LDAPv3.AttributeDescription import           LDAPv3.Message.Types+import           LDAPv3.OID import           LDAPv3.ResultCode  import qualified Data.Binary                 as Bin -import           Data.ASN1                   (Enumerated, NULL, OCTET_STRING, SET (..), SET1 (..))+import           Data.ASN1                   (Enumerated (..), NULL, OCTET_STRING, SET (..), SET1 (..)) #if defined(HS_LDAPv3_ANNOTATED) import           Data.ASN1                   (ASN1 (..), ASN1Constructed, BOOLEAN_DEFAULT (..), CHOICE (..),                                               COMPONENTS_OF (..), ENUMERATED (..), EXPLICIT (..),@@ -225,6 +233,8 @@ type EXPLICIT (tag :: TagK) x = x  -- | ASN.1 @ENUMERATED@ Annotation+--+-- See also 'Enumerated' class. type ENUMERATED x = x  -- | Helper representing a @BOOLEAN DEFAULT (TRUE|FALSE)@ ASN.1 type annotation@@ -350,14 +360,6 @@ instance ASN1 Control instance ASN1Constructed Control #endif--{- | Object identifier  (<https://tools.ietf.org/html/rfc4511#section-4.1.2 RFC4511 Section 4.1.2>)--> LDAPOID ::= OCTET STRING -- Constrained to <numericoid>->                          -- [RFC4512]---}-type LDAPOID = OID  ---------------------------------------------------------------------------- 

@@ -0,0 +1,396 @@+-- Copyright (c) 2023  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           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE Trustworthy                #-}++-- |+-- Copyright: © Herbert Valerio Riedel 2023+-- SPDX-License-Identifier: GPL-2.0-or-later+--+-- LDAP OID Helpers+--+-- This module provides helpers for dealing with the representation of /Object Identifiers/ (OID) in LDAP.+--+-- @since 0.1.2+module LDAPv3.OID+   ( -- * Textually encoded OIDs+     LDAPOID+   , OID(OID)++     -- * Binary encoded OIDs+   , OBJECT_IDENTIFIER+   , object_identifier'toOID+   , object_identifier'fromOID++   , object_identifier'toBin+   , object_identifier'fromBin++     -- * Convenience helpers+   , IsWellFormedOid(isWellFormedOid)+   ) where++import           Common                  hiding (Option, many, option, some, (<|>))+import           Data.ASN1+import           Data.ASN1.Prim+import           LDAPv3.StringRepr.Class++import qualified Data.Binary             as Bin+import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Char8   as BSC+import qualified Data.ByteString.Lazy    as BSL+import qualified Data.ByteString.Short   as SBS+import           Data.List+import qualified Data.Text               as T+import qualified Data.Text.Lazy          as TL+import           Data.Text.Lazy.Builder  as B+import qualified Data.Text.Short         as TS+import           Numeric                 (showHex)+import           Text.Parsec             as P++-- | Typeclass for 'isWellFormedOid' operation+--+-- @since 0.1.2+class IsWellFormedOid t where+  -- | Determine whether OID representation is deemed well-formed+  --+  -- An OID is considered well-formed /iff/ it has+  --+  --  * at least two arcs,+  --  * the first arc is one of @0@, @1@, or @2@, and+  --  * if the first arc is /not/ @2@, the second arc value is within the range @[0 .. 39]@.+  --+  -- Additionally, for string types the IETF-style ASCII dot notation with normalized (i.e. without redundant leading+  -- zeros) decimal numbers is expected (e.g. @1.23.456.7.890@) as expressed by the @numericoid@ ABNF production shown+  -- below:+  --+  -- > numericoid = number 1*( DOT number )+  -- > number  = DIGIT / ( LDIGIT 1*DIGIT )+  -- > DIGIT   = %x30 / LDIGIT       ; "0"-"9"+  -- > LDIGIT  = %x31-39             ; "1"-"9"+  --+  -- @since 0.1.2+  isWellFormedOid :: t -> Bool+++{- | Object identifier  (<https://tools.ietf.org/html/rfc4511#section-4.1.2 RFC4511 Section 4.1.2>)++> LDAPOID ::= OCTET STRING -- Constrained to <numericoid>+>                          -- [RFC4512]++@since 0.1.0+-}+type LDAPOID = OID+++{- | Numeric Object Identifier (OID)++> numericoid = number 1*( DOT number )+> number  = DIGIT / ( LDIGIT 1*DIGIT )+> DIGIT   = %x30 / LDIGIT       ; "0"-"9"+> LDIGIT  = %x31-39             ; "1"-"9"++NB: The current type definition and its 'StringRepr' instance currently allows to represent and parse more than the ABNF+    described above; moreover, the ABNF is also more liberal as it doesn't express the constraints imposed upon the+    first two arcs by @X.660@ and @ASN.1@. See also 'isWellFormedOid'.++@since 0.1.0+-}+newtype OID = OID (NonEmpty Natural)+  deriving (Eq,Ord,Show,NFData)++instance Newtype OID (NonEmpty Natural)++instance ASN1 OID where+  asn1defTag _   = asn1defTag (Proxy :: Proxy OCTET_STRING)+  asn1encode oid = asn1encode (BSC.pack (s'OID oid))+  asn1decode     = asn1decodeParsec "OID" p'OID++instance StringRepr OID where+  asBuilder       = B.fromString . s'OID+  renderShortText = TS.fromString . s'OID+  asParsec        = p'OID++-- Ideally this instance will become redundant/trivial in the future as it currently papers over an inadequacy in the+-- current definition of the 'OID' type+instance IsWellFormedOid OID where+  isWellFormedOid (OID s) = case s of+    0 :| (y:_) | y < 40 -> True+    1 :| (y:_) | y < 40 -> True+    2 :| (_:_)          -> True+    _                   -> False++-- the main cost is dealing with formatting the 'Natural' components and it's not obvious if it's worth the complexity+-- optimizing a more direct path for 'ShortText'+s'OID :: OID -> String+s'OID (OID (x:|xs)) = intercalate "." (map show (x:xs))++p'OID :: Stream s Identity Char => Parsec s () OID+p'OID = p'numericoid+  where+    -- numericoid = number 1*( DOT number )+    p'numericoid = OID <$> (p'number `sepBy1'` char '.')++    -- number  = DIGIT / ( LDIGIT 1*DIGIT )+    -- DIGIT   = %x30 / LDIGIT       ; "0"-"9"+    -- LDIGIT  = %x31-39             ; "1"-"9"+    p'number = do+      ldigit <- digit+      if ldigit == '0'+         then pure 0+         else read . (ldigit:) <$> many digit++{-# INLINE wf'OID #-}+wf'OID :: String -> Bool+wf'OID = \case+    '0':'.':rest -> go01 rest+    '1':'.':rest -> go01 rest+    '2':'.':rest -> go rest+    _            -> False+  where+    -- enforce 2nd arc to be within (canonically represented) [0..39] range+    go01 [d1]    | isD d1                       = True+    go01 [d1,d2] | d1 >= '1', d1 <= '3', isD d2 = True+    go01 (d1:'.':rest)    | isD d1                       = go rest+    go01 (d1:d2:'.':rest) | d1 >= '1', d1 <= '3', isD d2 = go rest+    go01 _ = False++    -- subsequent arcs without upper bounds+    go (c:rest)+      | c == '0' = case rest of+                    []        -> True+                    '.':rest' -> go rest'+                    _         -> False+      | isNZD c = case dropWhile isD rest of+                    []        -> True+                    '.':rest' -> go rest'+                    _:_       -> False+    go _ = False++    isNZD c = c >= '1' && c <= '9'+    isD c   = c >= '0' && c <= '9'++-- the instances below work best if the compiler manages to optimize away the intermediate @[Char]@ ...++instance IsWellFormedOid ShortText where+    isWellFormedOid = wf'OID . TS.unpack++instance IsWellFormedOid T.Text where+    isWellFormedOid = wf'OID . T.unpack++instance IsWellFormedOid TL.Text where+    isWellFormedOid = wf'OID . TL.unpack+++-- | ASN.1 @OBJECT IDENTIFIER@+--+-- The 'OID' type uses the textual LDAP encoding when converted to/from ASN.1 whereas this type provides the proper ASN.1 encoding as defined per X.690 section 8.19 (accessible via its 'Binary' instance).+--+-- @since 0.1.2+newtype OBJECT_IDENTIFIER = OID_ SBS.ShortByteString {- content encoded as per X.690 sec. 8.19 -}+  deriving (Eq,NFData)++instance Show OBJECT_IDENTIFIER where+    showsPrec _ (OID_ z) = ("OID<"++) . (\s -> foldr hex8 s (SBS.unpack z)) . ('>':)+      where+        hex8 :: Word8 -> ShowS+        hex8 x+          | x < 0x10  = ('0':) . showHex x+          | otherwise = showHex x++-- | Lexicographic ordering+instance Ord OBJECT_IDENTIFIER where+  compare = compareSubIds++instance ASN1 OBJECT_IDENTIFIER where+  asn1defTag _ = Universal 6+  asn1encode (OID_ sbs) = retag (Universal 6) $ asn1encode sbs+  asn1decode = implicit (Universal 6)+               (asn1decode `transformVia`+                (maybe (Left "not well-formed OBJECT IDENTIFIER") Right . object_identifier'fromBin))++instance StringRepr OBJECT_IDENTIFIER where+  asBuilder       = asBuilder . object_identifier'toOID+  renderShortText = renderShortText . object_identifier'toOID+  asParsec        = do+    x <- p'OID+    case object_identifier'fromOID x of+      Nothing -> fail "invalid top-level arcs"+      Just y  -> pure y++-- | Encodes as ASN.1 BER\/DER with @UNIVERSAL 6@ tag as per X.690 section 8.19+instance Bin.Binary OBJECT_IDENTIFIER where+  get = toBinaryGet asn1decode+  put = void . toBinaryPut . asn1encode++-- | Trivial instance as 'OBJECT_IDENTIFIER' values are always well-formed by construction+instance IsWellFormedOid OBJECT_IDENTIFIER where+  isWellFormedOid = const True++-- | Encode as raw ASN.1 BER\/DER value (i.e. without tag & length)+--+-- NB: As this function simply returns the internal representation this operation has zero cost.+--+-- @since 0.1.2+object_identifier'toBin :: OBJECT_IDENTIFIER -> SBS.ShortByteString+object_identifier'toBin (OID_ sbs) = sbs++-- | Decode from raw ASN.1 BER\/DER value (i.e. without tag & length)+--+-- All byte sequences are deemed well-formed raw ASN.1 OID encodings that satisfy the simple rules below (which ought to result in the same syntax as the rules specified in X.690 section 8.19.):+--+--  * The sequence must end with an octet with a value below @0x80@ (i.e. unset MSB), and+--  * any @0x80@ octet must be directly preceded by an octet which must have a value equal or greater than @0x80@ (i.e. set MSB).+--+-- In case these rules are not satisfied this function returns 'Nothing'.+--+-- NB: As this encoding matches the internal representation the resulting 'OBJECT_IDENTIFIER' merely @newtype@-wraps the input argument on success.+--+-- @since 0.1.2+object_identifier'fromBin :: SBS.ShortByteString -> Maybe OBJECT_IDENTIFIER+object_identifier'fromBin z+  | isValid   = Just (OID_ z)+  | otherwise = Nothing+  where+    isValid = case SBS.unpack z of+      [] -> False+      xs -> go 0x00 xs++    go pre []       = pre < 0x80+    go pre (0x80:xs)+      | pre >= 0x80 = go 0x80 xs+      | otherwise   = False+    go _ (x:xs)     = go x xs++-- | Convert 'OBJECT_IDENTIFIER' into 'OID' representation+--+-- @since 0.1.2+object_identifier'toOID :: OBJECT_IDENTIFIER -> OID+object_identifier'toOID oid = case decodeSubIds oid of+  [] -> error "the impossible just happened: internal invariant of OBJECT_IDENTIFIER broken"+  (i0:is)+    | i0 < 40   -> OID (0 :| (i0 : is))+    | i0 < 80   -> OID (1 :| (i0-40 : is))+    | otherwise -> OID (2 :| (i0-80 : is))++-- NB: the next major version shall avoid the 'Maybe' in the typesig+-- | Try to 'OID' representation into 'OBJECT_IDENTIFIER' representation+--+-- NB: This will return 'Nothing' /iff/ 'isWellFormedOid' returns 'False' on the input argument.+--+-- @since 0.1.2+object_identifier'fromOID :: OID -> Maybe OBJECT_IDENTIFIER+object_identifier'fromOID (OID s) = case s of+  0 :| (y:rest) | y < 40 -> Just $ encodeSubIds (y :| rest)+  1 :| (y:rest) | y < 40 -> Just $ encodeSubIds (y+40 :| rest)+  2 :| (y:rest)          -> Just $ encodeSubIds (y+80 :| rest)+  _                      -> Nothing -- invalid OID++encodeSubIds :: NonEmpty Natural -> OBJECT_IDENTIFIER+encodeSubIds (z:|zs) = OID_ $ SBS.toShort $ BSL.toStrict $ BSB.toLazyByteString $ mconcat (map subid (z:zs))+  where+    subid :: Natural -> BSB.Builder+    subid x+      | x < 0x100000000 {- i.e. 2^32 -} = encodeWord32 False (fromIntegral x) -- shortcut+      | otherwise = let (x',x'') = fmap fromIntegral (quotRem x 0x10000000) -- NB: 0x80^4, *not* 2^32+                    in subid1 x' `mappend` encodeWord32 True x''++    subid1 :: Natural -> BSB.Builder+    subid1 0 = mempty -- NB: never reached due to shortcut+    subid1 x+      | x < 0x80 = BSB.word8 (fromIntegral x .|. 0x80) -- shortcut+      | otherwise = let (x',x'') = fmap fromIntegral (quotRem x 0x80)+                    in subid1 x' `mappend` (BSB.word8 (x'' .|. 0x80))++    -- fast-path for 32bit values encoded in up to 5 octects;+    -- if enabled, pre-pad with 0x80 octects to 4 octets+    encodeWord32 :: Bool -> Word32 -> BSB.Builder+    encodeWord32 dopad w+      | w < 0x80     = pad' (BSB.word16BE 0x8080 <> BSB.word8 0x80) $+            BSB.word8 (fromIntegral w)+      | w < 0x4000   = pad' (BSB.word16BE 0x8080) $+            BSB.word8 (fromIntegral (w `unsafeShiftR`  7) .|. 0x80) <>+            BSB.word8 (fromIntegral w .&. 0x7f)+      | w < 0x200000 = pad' (BSB.word8 0x80) $+            BSB.word8 (fromIntegral (w `unsafeShiftR` 14) .|. 0x80) <>+            BSB.word8 (fromIntegral (w `unsafeShiftR`  7) .|. 0x80) <>+            BSB.word8 (fromIntegral w .&. 0x7f)+      | w < 0x10000000 =+            BSB.word8 (fromIntegral (w `unsafeShiftR` 21) .|. 0x80) <>+            BSB.word8 (fromIntegral (w `unsafeShiftR` 14) .|. 0x80) <>+            BSB.word8 (fromIntegral (w `unsafeShiftR`  7) .|. 0x80) <>+            BSB.word8 (fromIntegral w .&. 0x7f)+      | dopad = error "the impossible happened (encodeWord32)"+      | otherwise =+            BSB.word8 (fromIntegral (w `unsafeShiftR` 28) .|. 0x80) <>+            BSB.word8 (fromIntegral (w `unsafeShiftR` 21) .|. 0x80) <>+            BSB.word8 (fromIntegral (w `unsafeShiftR` 14) .|. 0x80) <>+            BSB.word8 (fromIntegral (w `unsafeShiftR`  7) .|. 0x80) <>+            BSB.word8 (fromIntegral w .&. 0x7f)+      where+        pad' thepad x+          | dopad     = thepad <> x+          | otherwise = x+++decodeSubIds :: OBJECT_IDENTIFIER -> [Natural]+decodeSubIds (OID_ b) = go0 (SBS.unpack b)+  where+    go0 [] = []+    go0 (x:rest)+      | x < 0x80 = fromIntegral x : go0 rest+      | otherwise = go1 (shift7 $ stripMsb x) rest++    go1 _ [] = error "the impossible just happened: internal invariant of OBJECT_IDENTIFIER broken"+    go1 acc (x:rest)+      | x < 0x80  = (acc + fromIntegral x) : go0 rest+      | otherwise = go1 (shift7 $ acc + stripMsb x) rest++    stripMsb :: Word8 -> Natural+    stripMsb x = fromIntegral (x .&. 0x7f)++    shift7 :: Natural -> Natural+    shift7 x = x `unsafeShiftL` 7++-- efficient lexicographic streaming+--+-- This is supposed to be semantically equivalent to+--+-- > compareSubIds x y = compare (decodeSubIds x) (decodeSubIds y)+--+-- NB: this implementation relies on 'mappend' over 'Ordering' shortcutting+compareSubIds :: OBJECT_IDENTIFIER -> OBJECT_IDENTIFIER -> Ordering+compareSubIds x y | x == y = EQ -- fast shortcut+compareSubIds (OID_ bx) (OID_ by) = go EQ (SBS.unpack bx) (SBS.unpack by)+  where+    go c (x:xs) (y:ys)+      | finX, finY = c <> compare x y <> go EQ xs ys+      | finX       = LT+      | finY       = GT+      | otherwise  = go (c <> compare x y) xs ys+      where+        finX = x < 0x80+        finY = y < 0x80++    go EQ (_:_) [] = GT+    go EQ [] (_:_) = LT+    go EQ [] []    = EQ -- actually not reachable due to '==' short-cut++    go c xs ys = error $ "the impossible just happened: compareSubIds " ++ show (bx,by,c,xs,ys)

@@ -78,7 +78,16 @@           , (ResultCode'other                        ,80)           ] --- | 'LDAPv3.LDAPResult' Result Code+-- | 'LDAPv3.LDAPResult' Result Code (<https://tools.ietf.org/html/rfc4511#section-4.1.9 RFC4511 Section 4.1.9>)+--+-- NB: If you need access to the LDAPv3 protocol specific numeric result code values use 'Enumerated' rather than 'Enum'!+--+-- >>> fromEnum ResultCode'unwillingToPerform+-- 29+--+-- >>> fromEnumerated ResultCode'unwillingToPerform+-- 53+-- data ResultCode     = ResultCode'success     | ResultCode'operationsError

@@ -14,7 +14,13 @@ --  along with this program (see `LICENSE`).  If not, see --  <https://www.gnu.org/licenses/old-licenses/gpl-2.0.html>. --- | String representation of+{-# LANGUAGE Trustworthy #-}++-- |+-- Copyright: © Herbert Valerio Riedel 2019+-- SPDX-License-Identifier: GPL-2.0-or-later+--+--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>

@@ -26,16 +26,19 @@  import           LDAPv3.ASN1String import           LDAPv3.Message-import           LDAPv3.StringRepr         (DistinguishedName(..))+import           LDAPv3.OID+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.Maybe                (fromJust)+import           Data.Proxy                (Proxy (..)) import           Data.String               (fromString) import qualified Data.Text.Short           as TS+import           Data.Word import           Test.QuickCheck.Instances () import           Test.Tasty.QuickCheck @@ -288,8 +291,18 @@ a'leadkeychar :: Gen Char a'leadkeychar = choose ('A', 'z') `suchThat` C.isLetter +-- generates only well-formed subset instance Arbitrary OID where-  arbitrary = OID <$> arbitrary+  arbitrary = (OID . fmap fromIntegral) <$> oneof+      [ (0 :|) <$> ((:) <$> ch40 <*> arbitrary)+      , (1 :|) <$> ((:) <$> ch40 <*> arbitrary)+      , (2 :|) <$> ((:) <$> arbitrary <*> arbitrary)+      ]+    where+      ch40 = choose (0 :: Word64, 39)++instance Arbitrary OBJECT_IDENTIFIER where+  arbitrary = fromJust . object_identifier'fromOID <$> arbitrary  instance Arbitrary DistinguishedName where   shrink (DistinguishedName rdns) = map DistinguishedName $ genericShrink rdns

@@ -22,15 +22,19 @@  import           LDAPv3.ASN1String import           LDAPv3.Message+import           LDAPv3.OID import           LDAPv3.StringRepr  import qualified Codec.Base16          as B16 import           Control.DeepSeq import           Data.Binary           as Bin import qualified Data.ByteString.Lazy  as BSL+import qualified Data.ByteString.Short as BSS import           Data.Char             (isSpace) import           Data.Either import           Data.List.NonEmpty    (NonEmpty (..))+import           Data.Maybe            (mapMaybe)+import qualified Data.Text             as T import qualified Data.Text.Short       as TS  import           Test.Tasty@@ -42,12 +46,110 @@ main :: IO () main = defaultMain tests -tests, qcPropsRFC4511, qcPropsRFC4515, unitTestsRFC4511, unitTestsRFC4515, unitTestsRFC4514, qcPropsRFC4514, qcPropsASN1String :: TestTree+tests, qcPropsRFC4511, qcPropsRFC4515, unitTestsRFC4511, unitTestsRFC4515, unitTestsRFC4514, qcPropsRFC4514, qcPropsASN1String, unitTestsOID, qcPropsOID :: TestTree -tests = testGroup "Tests" [unitTestsRFC4515, unitTestsRFC4511, qcPropsRFC4515, qcPropsRFC4511, unitTestsRFC4514, qcPropsRFC4514, qcPropsASN1String]+tests = testGroup "Tests" [unitTestsOID, qcPropsOID, unitTestsRFC4515, unitTestsRFC4511, qcPropsRFC4515, qcPropsRFC4511, unitTestsRFC4514, qcPropsRFC4514, qcPropsASN1String] + ---------------------------------------------------------------------------------------------------- +unitTestsOID = testGroup "Golden tests (OID)"+    [ testGroup "isWellFormedOid(text) -> False" [ testCase (show x) $ isWellFormedOid x @?= False | x <- badOids  ]+    , testGroup "isWellFormedOid(text) -> True"  [ testCase (show x) $ isWellFormedOid x @?= True  | x <- goodOids ]+    , testGroup "isWellFormedOid(OID) -> False"  [ testCase (renderString x) $ isWellFormedOid x @?= False | x <- badOIDs ]+    , testGroup "object_identifier'fromOID (invalid)" [ testCase (renderString x) $ object_identifier'fromOID x @?= Nothing | x <- badOIDs ]+    , testGroup "object_identifier'toBin" [ testCase (show t) $ fmap object_identifier'toBin (parseShortText t) @?= Just b | (t,b) <- zip goodOids goodOidsBin ]+    , testGroup "object_identifier'fromBin" [ testCase (show t) $ object_identifier'fromBin b @?= parseShortText t | (t,b) <- zip goodOids goodOidsBin ]+    , testGroup "object_identifier'fromBin (invalid)"+      [ testCase ("<" ++ (T.unpack $ B16.encode b) ++ ">") $+          object_identifier'fromBin b @?= Nothing | b <- badOidsBin ]+    , testGroup "object_identifier'toOID" [ testCase (show t) $ (object_identifier'toOID <$> parseShortText t) @?= parseShortText t | t <- goodOids ]+    , testGroup "OBJECT_IDENTIFIER Binary roundtrip" [ testCase (renderString oid) $ Bin.decode (Bin.encode oid) @?= (oid :: OBJECT_IDENTIFIER) | oid <- mapMaybe parseShortText goodOids ]+    ]+  where+    badOIDs = [ OID (0 :| [])+              , OID (1 :| [])+              , OID (2 :| [])+              , OID (3 :| [0])+              , OID (0 :| [40])+              , OID (1 :| [40])+              ]++    badOids, goodOids :: [TS.ShortText]+    badOids  = [ "", "0", "1", "2", "3", ".", "0..0", "0.40", "0.0.", "1.40", "2.00", "00.0", "0.00", ".0", " 0.0", "0.0 ", "2.012", "2.0 ", "3.0", "0.0. ", "0.0.1 ", "0. ", "0.1 ", "0. .0", "0.40.0", "0.20.", "0.2 .0", "0.00.0" ]++    goodOids =+      [ "0.0"+      , "0.39"+      , "1.0"+      , "1.3"+      , "1.39"+      , "1.11.1"+      , "2.22.2"+      , "2.39.127"+      , "2.40"+      , "2.47"+      , "2.48"+      , "0.1.2"+      , "2.9876543210"+      , "0.1.2.3.4.5.6.7.8.9.0"+      , "1.3.6.1.4.1.1248.1.1.2.1.3.21.69.112.115.111.110.32.83.116.121.108.117.115.32.80.114.111.32.52.57.48.48"+      , "2.25.336702412625001560652410773774433371419"+      ]++    goodOidsBin =+      [ hex'"00"+      , hex'"27"+      , hex'"28"+      , hex'"2b"+      , hex'"4f"+      , hex'"3301"+      , hex'"6602"+      , hex'"777f"+      , hex'"78"+      , hex'"7f"+      , hex'"8100"+      , hex'"0102"+      , hex'"a4e5c0ae3a"+      , hex'"01020304050607080900"+      , hex'"2B 06 01 04 01 89 60 01 01 02 01 03 15 45 70 73 6F 6E 20 53 74 79 6C 75 73 20 50 72 6F 20 34 39 30 30"+      , hex'"69 83 FA CE C3 A8 86 F1 F8 C7 BF A8 D8 80 80 AA AE D7 8A 1B"+      ]++    badOidsBin =+      [ hex'""+      , hex'"80"+      , hex'"8000"+      , hex'"008000"+      , hex'"00808101"+      , hex'"81"+      , hex'"0081"+      , hex'"008180"+      , hex'"808100"+      ]++qcPropsOID = testGroup "Properties (OID)"+    [ QC.testProperty "isWellFormedOid" $+        \oid -> isWellFormedOid (oid :: OID) === True++    , QC.testProperty "isWellFormedOid/renderShortText" $+        \oid -> isWellFormedOid (renderShortText (oid :: OID)) === True++    , QC.testProperty "OBJECT IDENTIFIER toBin/FromBin roundtrip" $+        \oid -> object_identifier'fromBin (object_identifier'toBin oid) === Just oid++    , QC.testProperty "OBJECT IDENTIFIER toOID/FromOID roundtrip" $+        \oid -> object_identifier'fromOID (object_identifier'toOID oid) === Just oid++    , QC.testProperty "Ord(OID)==Ord(OBJECT_IDENTIFIER)" $+        \ oid1 oid2 -> Just (compare oid1 oid2) === (compare <$> object_identifier'fromOID oid1 <*> object_identifier'fromOID oid2)++    , QC.testProperty "Ord(OBJECT_IDENTIFIER)==Ord(OID)" $+        \ oid1 oid2 -> compare oid1 oid2 === compare (object_identifier'toOID oid1) (object_identifier'toOID oid2)+    ]++----------------------------------------------------------------------------------------------------+ qcPropsRFC4515 = testGroup "Properties (RFC4515)"   [ QC.testProperty "parse/render Filter roundtrip" $       \f -> parseShortText (renderShortText (f :: Filter)) === Just f@@ -745,3 +847,6 @@  hex :: TS.ShortText -> BSL.ByteString hex = either error id . B16.decode . TS.toShortByteString . TS.filter (not . isSpace)++hex' :: TS.ShortText -> BSS.ShortByteString+hex' = BSS.toShort . BSL.toStrict . hex