diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/LDAPv3.cabal b/LDAPv3.cabal --- a/LDAPv3.cabal +++ b/LDAPv3.cabal @@ -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: diff --git a/src/Data/ASN1.hs b/src/Data/ASN1.hs --- a/src/Data/ASN1.hs +++ b/src/Data/ASN1.hs @@ -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 diff --git a/src/LDAPv3/ASN1String.hs b/src/LDAPv3/ASN1String.hs --- a/src/LDAPv3/ASN1String.hs +++ b/src/LDAPv3/ASN1String.hs @@ -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. -- diff --git a/src/LDAPv3/AttributeDescription.hs b/src/LDAPv3/AttributeDescription.hs --- a/src/LDAPv3/AttributeDescription.hs +++ b/src/LDAPv3/AttributeDescription.hs @@ -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 diff --git a/src/LDAPv3/DistinguishedName.hs b/src/LDAPv3/DistinguishedName.hs --- a/src/LDAPv3/DistinguishedName.hs +++ b/src/LDAPv3/DistinguishedName.hs @@ -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) | -- +--------+-----------------------------------------------+ -- diff --git a/src/LDAPv3/Message.hs b/src/LDAPv3/Message.hs --- a/src/LDAPv3/Message.hs +++ b/src/LDAPv3/Message.hs @@ -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 . +-- | +-- 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 . +-- -- Serializing and deserializing to and from the wire 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 () - -> LDAPOID ::= OCTET STRING -- Constrained to -> -- [RFC4512] - --} -type LDAPOID = OID ---------------------------------------------------------------------------- diff --git a/src/LDAPv3/OID.hs b/src/LDAPv3/OID.hs new file mode 100644 --- /dev/null +++ b/src/LDAPv3/OID.hs @@ -0,0 +1,396 @@ +-- Copyright (c) 2023 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 #-} +{-# 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 () + +> LDAPOID ::= OCTET STRING -- Constrained to +> -- [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) diff --git a/src/LDAPv3/ResultCode.hs b/src/LDAPv3/ResultCode.hs --- a/src/LDAPv3/ResultCode.hs +++ b/src/LDAPv3/ResultCode.hs @@ -78,7 +78,16 @@ , (ResultCode'other ,80) ] --- | 'LDAPv3.LDAPResult' Result Code +-- | 'LDAPv3.LDAPResult' Result Code () +-- +-- 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 diff --git a/src/LDAPv3/StringRepr.hs b/src/LDAPv3/StringRepr.hs --- a/src/LDAPv3/StringRepr.hs +++ b/src/LDAPv3/StringRepr.hs @@ -14,7 +14,13 @@ -- along with this program (see `LICENSE`). If not, see -- . --- | 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 -- * LDAPv3 'DistinguishedName's as defined by diff --git a/test/Arbitrary.hs b/test/Arbitrary.hs --- a/test/Arbitrary.hs +++ b/test/Arbitrary.hs @@ -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 diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -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