LDAPv3-0.1.2.0: test/Arbitrary.hs

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