-- Copyright (c) 2019 Herbert Valerio Riedel -- -- This file is free software: you may copy, redistribute and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation, either version 2 of the License, or (at your -- option) any later version. -- -- This file is distributed in the hope that it will be useful, but -- WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program (see `LICENSE`). If not, see -- . {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Arbitrary () where import LDAPv3.ASN1String import LDAPv3.Message 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.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 instance Arbitrary TS.ShortText where arbitrary = TS.fromText <$> arbitrary shrink t = map TS.fromText (shrink (TS.toText t)) -- instance Arbitrary x => Arbitrary (IMPLICIT tag x) where -- arbitrary = IMPLICIT <$> arbitrary -- shrink (IMPLICIT x) = coerce (shrink x) -- instance Arbitrary x => Arbitrary (EXPLICIT tag x) where -- arbitrary = EXPLICIT <$> arbitrary -- shrink (EXPLICIT x) = coerce (shrink x) instance Arbitrary x => Arbitrary (SET x) where arbitrary = SET <$> arbitrary shrink (SET x) = coerce (shrink x) instance Arbitrary x => Arbitrary (SET1 x) where arbitrary = SET1 <$> arbitrary shrink (SET1 x) = coerce (shrink x) instance Arbitrary MessageID where arbitrary = MessageID <$> arbitrary shrink (MessageID i) = coerce (shrink i) instance Arbitrary (UInt 1 127 Int8) where arbitrary = either (\_ -> 1) id . toUInt <$> choose (1,127) instance Arbitrary (UInt 0 MaxInt Int32) where arbitrary = int2msgid <$> arbitrary shrink = map int2msgid . shrink . fromUInt int2msgid :: Int32 -> UInt 0 MaxInt Int32 int2msgid = either (\_ -> 0) id . toUInt . abs instance Arbitrary ResultCode where arbitrary = arbitraryBoundedEnum shrink ResultCode'success = [] shrink _ = [ResultCode'success] instance Arbitrary LDAPMessage where arbitrary = LDAPMessage <$> arbitrary <*> arbitrary <*> arbitrary shrink = genericShrink -- instance Arbitrary (BOOLEAN_DEFAULT b) where -- arbitrary = BOOLEAN <$> arbitrary instance Arbitrary Control where arbitrary = Control <$> arbitrary <*> arbitrary <*> arbitrary shrink = genericShrink instance Arbitrary LDAPResult where arbitrary = LDAPResult <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary shrink = genericShrink instance Arbitrary ProtocolOp where arbitrary = frequency [ (2, ProtocolOp'bindRequest <$> arbitrary) , (2, ProtocolOp'bindResponse <$> arbitrary) , (1, ProtocolOp'unbindRequest <$> arbitrary) , (5, ProtocolOp'searchRequest <$> arbitrary) , (1, ProtocolOp'searchResDone <$> arbitrary) , (5, ProtocolOp'searchResEntry <$> arbitrary) , (2, ProtocolOp'searchResRef <$> arbitrary) , (2, ProtocolOp'modifyRequest <$> arbitrary) , (1, ProtocolOp'modifyResponse <$> arbitrary) , (2, ProtocolOp'addRequest <$> arbitrary) , (1, ProtocolOp'addResponse <$> arbitrary) , (1, ProtocolOp'delRequest <$> arbitrary) , (1, ProtocolOp'delResponse <$> arbitrary) , (2, ProtocolOp'modDNRequest <$> arbitrary) , (1, ProtocolOp'modDNResponse <$> arbitrary) , (2, ProtocolOp'compareRequest <$> arbitrary) , (1, ProtocolOp'compareResponse <$> arbitrary) , (1, ProtocolOp'abandonRequest <$> arbitrary) , (2, ProtocolOp'extendedReq <$> arbitrary) , (2, ProtocolOp'extendedResp <$> arbitrary) , (2, ProtocolOp'intermediateResponse <$> arbitrary) ] shrink = genericShrink instance Arbitrary BindRequest where arbitrary = BindRequest <$> arbitrary <*> arbitrary <*> arbitrary shrink = genericShrink instance Arbitrary AuthenticationChoice where arbitrary = oneof [ AuthenticationChoice'simple <$> arbitrary , AuthenticationChoice'sasl <$> arbitrary ] shrink = genericShrink instance Arbitrary SaslCredentials where arbitrary = SaslCredentials <$> arbitrary <*> arbitrary shrink = genericShrink instance Arbitrary BindResponse where arbitrary = BindResponse <$> arbitrary <*> arbitrary shrink = genericShrink instance Arbitrary SearchRequest where arbitrary = SearchRequest <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary shrink = genericShrink instance Arbitrary Scope where arbitrary = arbitraryBoundedEnum shrink = genericShrink instance Arbitrary DerefAliases where arbitrary = arbitraryBoundedEnum shrink = genericShrink instance Arbitrary Filter where arbitrary = frequency [( 1, Filter'and <$> arbitrary) ,( 1, Filter'or <$> arbitrary) ,( 1, Filter'not <$> arbitrary) ,(100, Filter'equalityMatch <$> arbitrary) ,(100, Filter'substrings <$> arbitrary) ,(100, Filter'greaterOrEqual <$> arbitrary) ,(100, Filter'lessOrEqual <$> arbitrary) ,(100, Filter'present <$> arbitrary) ,(100, Filter'approxMatch <$> arbitrary) ,(100, Filter'extensibleMatch <$> arbitrary) ] shrink = genericShrink instance Arbitrary SubstringFilter where arbitrary = SubstringFilter <$> arbitrary <*> sub'arbitrary where sub'arbitrary = do initial <- oneof [ ((:[]) . Substring'initial) <$> nonEmptyBS, pure [] ] final <- oneof [ ((:[]) . Substring'final) <$> nonEmptyBS, pure [] ] anys <- case (initial,final) of ([],[]) -> listOf nonEmptyBS `suchThat` (not . null) _ -> listOf nonEmptyBS case (initial ++ map Substring'any anys ++ final) of [] -> error "the impossible just happened" (x:xs) -> pure (x:|xs) nonEmptyBS = arbitrary `suchThat` (not . BS.null) shrink = genericShrink instance Arbitrary MatchingRuleAssertion where arbitrary = do _MatchingRuleAssertion'matchingRule <- arbitrary -- /If the @matchingRule@ field is absent, the @type@ field MUST be present/ _MatchingRuleAssertion'type <- case _MatchingRuleAssertion'matchingRule of Just _ -> arbitrary Nothing -> Just <$> arbitrary _MatchingRuleAssertion'matchValue <- arbitrary _MatchingRuleAssertion'dnAttributes <- arbitrary pure MatchingRuleAssertion {..} shrink = genericShrink instance Arbitrary Substring where arbitrary = oneof [ Substring'initial <$> nonEmptyBS , Substring'any <$> nonEmptyBS , Substring'final <$> nonEmptyBS ] where nonEmptyBS = arbitrary `suchThat` (not . BS.null) -- shrink = genericShrink instance Arbitrary SearchResultEntry where arbitrary = SearchResultEntry <$> arbitrary <*> arbitrary shrink = genericShrink instance Arbitrary PartialAttribute where arbitrary = PartialAttribute <$> arbitrary <*> arbitrary shrink = genericShrink instance Arbitrary Attribute where arbitrary = Attribute <$> arbitrary <*> arbitrary shrink = genericShrink instance Arbitrary SearchResultReference where arbitrary = SearchResultReference <$> arbitrary shrink = genericShrink instance Arbitrary ModifyRequest where arbitrary = ModifyRequest <$> arbitrary <*> arbitrary shrink = genericShrink instance Arbitrary Change where arbitrary = Change <$> arbitrary <*> arbitrary shrink = genericShrink instance Arbitrary Operation where arbitrary = arbitraryBoundedEnum shrink = genericShrink instance Arbitrary AddRequest where arbitrary = AddRequest <$> arbitrary <*> arbitrary shrink = genericShrink instance Arbitrary CompareRequest where arbitrary = CompareRequest <$> arbitrary <*> arbitrary shrink = genericShrink instance Arbitrary AttributeValueAssertion where arbitrary = AttributeValueAssertion <$> arbitrary <*> arbitrary shrink = genericShrink instance Arbitrary ModifyDNRequest where arbitrary = ModifyDNRequest <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary shrink = genericShrink instance Arbitrary ExtendedRequest where arbitrary = ExtendedRequest <$> arbitrary <*> arbitrary shrink = genericShrink instance Arbitrary ExtendedResponse where arbitrary = ExtendedResponse <$> arbitrary <*> arbitrary <*> arbitrary shrink = genericShrink instance Arbitrary IntermediateResponse where arbitrary = IntermediateResponse <$> arbitrary <*> arbitrary shrink = genericShrink instance Arbitrary AttributeDescription where arbitrary = AttributeDescription <$> arbitrary <*> arbitrary shrink = genericShrink instance Arbitrary MatchingRuleId where arbitrary = MatchingRuleId <$> (arbitrary `suchThat` (/= Left "dn")) -- avoid grammar ambiguity shrink = genericShrink instance Arbitrary KeyString where arbitrary = fromString <$> ((:) <$> a'leadkeychar <*> listOf a'keychar) instance Arbitrary Option where arbitrary = fromString <$> (listOf a'keychar `suchThat` (not . null)) a'keychar :: Gen Char a'keychar = choose ('-', 'z') `suchThat` (\c -> C.isAsciiUpper c || C.isAsciiLower c || C.isDigit c || c == '-') a'leadkeychar :: Gen Char a'leadkeychar = choose ('A', 'z') `suchThat` C.isLetter -- generates only well-formed subset instance Arbitrary OID where 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 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']