LDAPv3 (empty) → 0.0.0.0

raw patch · 10 files changed

+3675/−0 lines, 10 filesdep +LDAPv3dep +basedep +base-encoding

Dependencies added: LDAPv3, base, base-encoding, binary, bytestring, containers, deepseq, int-cast, newtype, quickcheck-instances, semigroups, tasty, tasty-hunit, tasty-quickcheck, text-short

Files

• LDAPv3.cabal +90/−0
• LICENSE +341/−0
• src/Common.hs +29/−0
• src/Data/ASN1.hs +671/−0
• src/Data/ASN1/Prim.hs +336/−0
• src/Data/Int/Subtypes.hs +199/−0
• src/LDAPv3.hs +1180/−0
• src/LDAPv3/ResultCode.hs +140/−0
• test/Arbitrary.hs +234/−0
• test/main.hs +455/−0

@@ -0,0 +1,90 @@+cabal-version:       2.2+name:                LDAPv3+version:             0.0.0.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+maintainer:          hvr@gnu.org+bug-reports:         https://github.com/hvr/LDAPv3/issues+category:            Network+description:+  This library 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 for the purpose of implementing network clients and servers is supported via 'Binary' instances (see <//hackage.haskell.org/package/binary 'binary' package>).++source-repository head+  type:     git+  location: https://github.com/hvr/LDAPv3.git++common defaults+  default-language: Haskell2010+  other-extensions:+    BangPatterns+    ConstraintKinds+    DataKinds+    DeriveFunctor+    DeriveGeneric+    FlexibleContexts+    FlexibleInstances+    GeneralizedNewtypeDeriving+    KindSignatures+    LambdaCase+    MultiParamTypeClasses+    RecordWildCards+    ScopedTypeVariables+    TypeFamilies+    TypeOperators+    UndecidableInstances++  build-depends:+    , base          >= 4.8 && < 4.14+    , binary       ^>= 0.8.3+    , bytestring   ^>= 0.10.4+    , text-short   ^>= 0.1.3+    , containers   ^>= 0.5.5 || ^>= 0.6.0+    , deepseq      ^>= 1.4.0+    , int-cast     ^>= 0.2.0+    , newtype      ^>= 0.2.2++  if !impl(ghc >= 8.0)+    build-depends:+      , semigroups ^>= 0.19.1++  ghc-options: -Wall++-------------------------------------------------------------------------------++library+  import: defaults++  hs-source-dirs: src+  exposed-modules:+      LDAPv3+  other-modules:+      Common+      Data.Int.Subtypes+      Data.ASN1+      Data.ASN1.Prim+      LDAPv3.ResultCode++-------------------------------------------------------------------------------++test-suite LDAPv3+  import: defaults++  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: main.hs+  other-modules: Arbitrary++  build-depends:+    , LDAPv3++    , tasty            ^>= 1.2.3+    , tasty-quickcheck ^>= 0.10.1+    , tasty-hunit      ^>= 0.10.0+    , base-encoding    ^>= 0.1.0+    , quickcheck-instances ^>= 0.3.22

@@ -0,0 +1,341 @@++             GNU GENERAL PUBLIC LICENSE+                Version 2, June 1991++ Copyright (C) 1989, 1991 Free Software Foundation, Inc.,+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++                     Preamble++  The licenses for most software are designed to take away your+freedom to share and change it.  By contrast, the GNU General Public+License is intended to guarantee your freedom to share and change free+software--to make sure the software is free for all its users.  This+General Public License applies to most of the Free Software+Foundation's software and to any other program whose authors commit to+using it.  (Some other Free Software Foundation software is covered by+the GNU Lesser General Public License instead.)  You can apply it to+your programs, too.++  When we speak of free software, we are referring to freedom, not+price.  Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+this service if you wish), that you receive source code or can get it+if you want it, that you can change the software or use pieces of it+in new free programs; and that you know you can do these things.++  To protect your rights, we need to make restrictions that forbid+anyone to deny you these rights or to ask you to surrender the rights.+These restrictions translate to certain responsibilities for you if you+distribute copies of the software, or if you modify it.++  For example, if you distribute copies of such a program, whether+gratis or for a fee, you must give the recipients all the rights that+you have.  You must make sure that they, too, receive or can get the+source code.  And you must show them these terms so they know their+rights.++  We protect your rights with two steps: (1) copyright the software, and+(2) offer you this license which gives you legal permission to copy,+distribute and/or modify the software.++  Also, for each author's protection and ours, we want to make certain+that everyone understands that there is no warranty for this free+software.  If the software is modified by someone else and passed on, we+want its recipients to know that what they have is not the original, so+that any problems introduced by others will not reflect on the original+authors' reputations.++  Finally, any free program is threatened constantly by software+patents.  We wish to avoid the danger that redistributors of a free+program will individually obtain patent licenses, in effect making the+program proprietary.  To prevent this, we have made it clear that any+patent must be licensed for everyone's free use or not licensed at all.++  The precise terms and conditions for copying, distribution and+modification follow.++             GNU GENERAL PUBLIC LICENSE+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++  0. This License applies to any program or other work which contains+a notice placed by the copyright holder saying it may be distributed+under the terms of this General Public License.  The "Program", below,+refers to any such program or work, and a "work based on the Program"+means either the Program or any derivative work under copyright law:+that is to say, a work containing the Program or a portion of it,+either verbatim or with modifications and/or translated into another+language.  (Hereinafter, translation is included without limitation in+the term "modification".)  Each licensee is addressed as "you".++Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope.  The act of+running the Program is not restricted, and the output from the Program+is covered only if its contents constitute a work based on the+Program (independent of having been made by running the Program).+Whether that is true depends on what the Program does.++  1. You may copy and distribute verbatim copies of the Program's+source code as you receive it, in any medium, provided that you+conspicuously and appropriately publish on each copy an appropriate+copyright notice and disclaimer of warranty; keep intact all the+notices that refer to this License and to the absence of any warranty;+and give any other recipients of the Program a copy of this License+along with the Program.++You may charge a fee for the physical act of transferring a copy, and+you may at your option offer warranty protection in exchange for a fee.++  2. You may modify your copy or copies of the Program or any portion+of it, thus forming a work based on the Program, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++    a) You must cause the modified files to carry prominent notices+    stating that you changed the files and the date of any change.++    b) You must cause any work that you distribute or publish, that in+    whole or in part contains or is derived from the Program or any+    part thereof, to be licensed as a whole at no charge to all third+    parties under the terms of this License.++    c) If the modified program normally reads commands interactively+    when run, you must cause it, when started running for such+    interactive use in the most ordinary way, to print or display an+    announcement including an appropriate copyright notice and a+    notice that there is no warranty (or else, saying that you provide+    a warranty) and that users may redistribute the program under+    these conditions, and telling the user how to view a copy of this+    License.  (Exception: if the Program itself is interactive but+    does not normally print such an announcement, your work based on+    the Program is not required to print an announcement.)++These requirements apply to the modified work as a whole.  If+identifiable sections of that work are not derived from the Program,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works.  But when you+distribute the same sections as part of a whole which is a work based+on the Program, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Program.++In addition, mere aggregation of another work not based on the Program+with the Program (or with a work based on the Program) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++  3. You may copy and distribute the Program (or a work based on it,+under Section 2) in object code or executable form under the terms of+Sections 1 and 2 above provided that you also do one of the following:++    a) Accompany it with the complete corresponding machine-readable+    source code, which must be distributed under the terms of Sections+    1 and 2 above on a medium customarily used for software interchange; or,++    b) Accompany it with a written offer, valid for at least three+    years, to give any third party, for a charge no more than your+    cost of physically performing source distribution, a complete+    machine-readable copy of the corresponding source code, to be+    distributed under the terms of Sections 1 and 2 above on a medium+    customarily used for software interchange; or,++    c) Accompany it with the information you received as to the offer+    to distribute corresponding source code.  (This alternative is+    allowed only for noncommercial distribution and only if you+    received the program in object code or executable form with such+    an offer, in accord with Subsection b above.)++The source code for a work means the preferred form of the work for+making modifications to it.  For an executable work, complete source+code means all the source code for all modules it contains, plus any+associated interface definition files, plus the scripts used to+control compilation and installation of the executable.  However, as a+special exception, the source code distributed need not include+anything that is normally distributed (in either source or binary+form) with the major components (compiler, kernel, and so on) of the+operating system on which the executable runs, unless that component+itself accompanies the executable.++If distribution of executable or object code is made by offering+access to copy from a designated place, then offering equivalent+access to copy the source code from the same place counts as+distribution of the source code, even though third parties are not+compelled to copy the source along with the object code.++  4. You may not copy, modify, sublicense, or distribute the Program+except as expressly provided under this License.  Any attempt+otherwise to copy, modify, sublicense or distribute the Program is+void, and will automatically terminate your rights under this License.+However, parties who have received copies, or rights, from you under+this License will not have their licenses terminated so long as such+parties remain in full compliance.++  5. You are not required to accept this License, since you have not+signed it.  However, nothing else grants you permission to modify or+distribute the Program or its derivative works.  These actions are+prohibited by law if you do not accept this License.  Therefore, by+modifying or distributing the Program (or any work based on the+Program), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Program or works based on it.++  6. Each time you redistribute the Program (or any work based on the+Program), the recipient automatically receives a license from the+original licensor to copy, distribute or modify the Program subject to+these terms and conditions.  You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties to+this License.++  7. If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Program at all.  For example, if a patent+license would not permit royalty-free redistribution of the Program by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Program.++If any portion of this section is held invalid or unenforceable under+any particular circumstance, the balance of the section is intended to+apply and the section as a whole is intended to apply in other+circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system, which is+implemented by public license practices.  Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.++  8. If the distribution and/or use of the Program is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Program under this License+may add an explicit geographical distribution limitation excluding+those countries, so that distribution is permitted only in or among+countries not thus excluded.  In such case, this License incorporates+the limitation as if written in the body of this License.++  9. The Free Software Foundation may publish revised and/or new versions+of the General Public License from time to time.  Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++Each version is given a distinguishing version number.  If the Program+specifies a version number of this License which applies to it and "any+later version", you have the option of following the terms and conditions+either of that version or of any later version published by the Free+Software Foundation.  If the Program does not specify a version number of+this License, you may choose any version ever published by the Free Software+Foundation.++  10. If you wish to incorporate parts of the Program into other free+programs whose distribution conditions are different, write to the author+to ask for permission.  For software which is copyrighted by the Free+Software Foundation, write to the Free Software Foundation; we sometimes+make exceptions for this.  Our decision will be guided by the two goals+of preserving the free status of all derivatives of our free software and+of promoting the sharing and reuse of software generally.++                     NO WARRANTY++  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,+REPAIR OR CORRECTION.++  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE+POSSIBILITY OF SUCH DAMAGES.++              END OF TERMS AND CONDITIONS++     How to Apply These Terms to Your New Programs++  If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++  To do so, attach the following notices to the program.  It is safest+to attach them to the start of each source file to most effectively+convey the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This program is free software; you can redistribute it 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 program 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; if not, write to the Free Software Foundation, Inc.,+    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.++Also add information on how to contact you by electronic and paper mail.++If the program is interactive, make it output a short notice like this+when it starts in an interactive mode:++    Gnomovision version 69, Copyright (C) year name of author+    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+    This is free software, and you are welcome to redistribute it+    under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License.  Of course, the commands you use may+be called something other than `show w' and `show c'; they could even be+mouse-clicks or menu items--whatever suits your program.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the program, if+necessary.  Here is a sample; alter the names:++  Yoyodyne, Inc., hereby disclaims all copyright interest in the program+  `Gnomovision' (which makes passes at compilers) written by James Hacker.++  <signature of Ty Coon>, 1 April 1989+  Ty Coon, President of Vice++This General Public License does not permit incorporating your program into+proprietary programs.  If your program is a subroutine library, you may+consider it more useful to permit linking proprietary applications with the+library.  If this is what you want to do, use the GNU Lesser General+Public License instead of this License.+

@@ -0,0 +1,29 @@+module Common (module Common, module X) where++import           Control.Applicative as X+import           Control.DeepSeq     as X (NFData (rnf))+import           Control.Exception   as X (ArithException (Overflow, Underflow), throw)+import           Control.Monad       as X+import           Control.Newtype     as X (Newtype (..))+import           Data.Bits           as X+import           Data.ByteString     as X (ByteString)+import           Data.Int            as X+import           Data.IntCast        as X+import           Data.List.NonEmpty  as X (NonEmpty (..))+import           Data.Maybe          as X+import           Data.Proxy          as X (Proxy (Proxy))+import           Data.Semigroup      as X+import           Data.Text.Short     as X (ShortText)+import           Data.Word           as X+import           GHC.Generics        as X (Generic)+import           GHC.TypeLits        as X++{-# INLINE rwhnf #-}+rwhnf :: a -> ()+rwhnf x = seq x ()++{-# INLINE inside #-}+inside :: Ord a => a -> (a, a) -> Bool+x `inside` (lb,ub)+  | lb > ub = error "inside: unsatifiable range"+  | otherwise = lb <= x && x <= ub

@@ -0,0 +1,671 @@+-- Copyright (c) 2018-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 ConstraintKinds            #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeOperators              #-}++module Data.ASN1+    ( ASN1(..)+    , ASN1Decode+    , ASN1Encode++    , ENUMERATED(..), Enumerated(..)+    , IMPLICIT(..), implicit+    , EXPLICIT(..), explicit++    , OCTET_STRING+    , NULL+    , BOOLEAN+    , BOOLEAN_DEFAULT_FALSE(..)+    , OPTIONAL++    , SET(..)+    , SET1(..)++    , toBinaryPut+    , toBinaryGet++    , retag, wraptag++    , with'SEQUENCE+    , enc'SEQUENCE+    , enc'SEQUENCE_COMPS++    , with'CHOICE++    , dec'BoundedEnum+    , enc'BoundedEnum++    , dec'NULL+    , enc'NULL+    ) where++import           Common+import           Data.ASN1.Prim+import           Data.Int.Subtypes++import           Data.Binary           as Bin+import           Data.Binary.Get       as Bin+import           Data.Binary.Put       as Bin+import           Data.Bool             (bool)+import qualified Data.ByteString       as BS+import qualified Data.ByteString.Short as SBS+import           Data.Set              (Set)+import qualified Data.Set              as Set+import           Data.String           (IsString)+import qualified Data.Text.Short       as TS++----------------------------------------------------------------------------++class Enumerated x where+  toEnumerated :: Int64 -> Maybe x+  fromEnumerated :: x -> Int64++instance Enumerated Int64 where+  toEnumerated = Just+  fromEnumerated = id++instance Enumerated Int where+  toEnumerated = intCastMaybe+  fromEnumerated = fromIntegral++----------------------------------------------------------------------------++data ASN1Res x = Consumed ({- leftover -} Maybe TL) x+               | Unexpected {- leftover -} TL+               | UnexpectedEOF+               deriving (Show,Functor)++newtype ASN1Encode a = ASN1Encode (Maybe Tag -> PutM a)++empty'ASN1Encode :: ASN1Encode Word64+empty'ASN1Encode = ASN1Encode $ \case+  Just _  -> error "empty'ASN1Encode: called with tag-override"+  Nothing -> pure 0++toBinaryPut :: ASN1Encode a -> PutM a+toBinaryPut (ASN1Encode body) = body Nothing++enc'SEQUENCE_COMPS :: [ASN1Encode Word64] -> ASN1Encode Word64+enc'SEQUENCE_COMPS [] = empty'ASN1Encode+enc'SEQUENCE_COMPS xs0 = ASN1Encode $ \case+    Just _  -> error "enc'SEQUENCE_COMPS: called with tag-override"+    Nothing -> go xs0 0+  where+    go [] sz = pure sz+    go (ASN1Encode x:xs) sz = do+      n1 <- x Nothing+      go xs (sz+n1)++enc'SEQUENCE :: [ASN1Encode Word64] -> ASN1Encode Word64+enc'SEQUENCE = wraptag (Universal 16) . enc'SEQUENCE_COMPS++enc'SET :: [ASN1Encode Word64] -> ASN1Encode Word64+enc'SET = retag (Universal 17) . enc'SEQUENCE++data ASN1Decode x = ASN1Decode { asn1dTags    :: !(Set Tag)+                               , asn1dAny     :: !Bool+                               , asn1dContent :: Maybe TL {- Nothing == EOF -} -> Get (ASN1Res x)+                               }+++++asn1DecodeSingleton :: Tag -> (TL -> Get x) -> ASN1Decode x+asn1DecodeSingleton t c = mempty { asn1dTags    = Set.singleton t+                                 , asn1dContent = \case+                                     Just tl@(t',_,_) | t /= t' -> pure (Unexpected tl)+                                                      | otherwise -> Consumed Nothing <$> c tl+                                     Nothing -> pure UnexpectedEOF+                                 }+++asn1DecodeSingleton' :: Tag -> (TL -> Get (ASN1Res x)) -> ASN1Decode x+asn1DecodeSingleton' t c = mempty { asn1dTags    = Set.singleton t+                                  , asn1dContent = \case+                                      Just tl@(t',_,_) | t /= t' -> pure (Unexpected tl)+                                                       | otherwise -> c tl+                                      Nothing -> pure UnexpectedEOF+                                  }+++asn1decodeIsSingleton :: ASN1Decode x -> Maybe Tag+asn1decodeIsSingleton (ASN1Decode {..})+  | asn1dAny                     = Nothing+  | [t1] <- Set.toList asn1dTags = Just t1+  | otherwise                    = Nothing++with'OPTIONAL :: ASN1Decode x -> ASN1Decode (Maybe x)+with'OPTIONAL x = x { asn1dAny = True+                    , asn1dContent = \case+                        Nothing -> pure $ Consumed Nothing Nothing+                        Just tl -> g <$> asn1dContent x (Just tl)+                    }+  where+    g (Consumed mleftover v) = Consumed mleftover (Just v)+    g (Unexpected leftover)  = Consumed (Just leftover) Nothing+    g UnexpectedEOF          = Consumed Nothing Nothing++-- | Left-biased "CHOICE" join (TODO: verify specific-match-first semantics are sane in presence of ANYs)+instance Semigroup (ASN1Decode x) where+  x <> y+    | asn1decodeIsEmpty x = y+    | asn1decodeIsEmpty y = x+    | otherwise = ASN1Decode+                  { asn1dTags = asn1dTags x <> asn1dTags y+                  , asn1dAny  = asn1dAny x || asn1dAny y+                  , asn1dContent = \case+                          tl@(Just (t,_,_)) -> case () of+                            _ | Set.member t (asn1dTags x) -> asn1dContent x tl+                              | Set.member t (asn1dTags y) -> asn1dContent y tl+                              | asn1dAny x -> asn1dContent x tl+                              | asn1dAny y -> asn1dContent y tl+                              | otherwise  -> fail "asn1dContent called with unsupported Tag" -- internal error+                          Nothing -> case () of+                            _ | asn1dAny x -> asn1dContent x Nothing+                              | asn1dAny y -> asn1dContent y Nothing+                              | otherwise  -> pure UnexpectedEOF+                  }++-- | Test whether 'mempty'+asn1decodeIsEmpty :: ASN1Decode x -> Bool+asn1decodeIsEmpty ASN1Decode{..} = not asn1dAny && Set.null asn1dTags++instance Monoid (ASN1Decode x) where+  mempty = ASN1Decode mempty False (pure . maybe UnexpectedEOF Unexpected)+  mappend = (<>)+  -- TODO: optimized mconcat++instance Functor ASN1Decode where+  fmap f dec = dec { asn1dContent = \tl -> fmap f <$> asn1dContent dec tl }++instance Applicative ASN1Decode where+  pure x = mempty { asn1dAny = True+                  , asn1dContent = \tl -> pure (Consumed tl x)+                  }+  (<*>) = ap++instance Monad ASN1Decode where+  return = pure -- redundant for base >= 4.8++  mx >>= k = ASN1Decode { asn1dAny = asn1dAny mx+                        , asn1dTags = asn1dTags mx+                        , asn1dContent = \mtl -> do+                            x0 <- getASN1Decode mx mtl+                            case x0 of+                              Consumed (Just tl') x -> do+                                getASN1Decode (k x) (Just tl')+                              Consumed Nothing x -> do+                                mtl' <- getTagLength BER+                                getASN1Decode (k x) mtl'+                              Unexpected (t,_,_) ->+                                fail ("ASN1Decode: Unexpected " ++ show t)+                              UnexpectedEOF ->+                                fail ("ASN1Decode: UnexpectedEOF")+                        }++-- instance MonadFail ASN1Decode where+--   fail = asn1fail++asn1fail :: String -> ASN1Decode a+asn1fail s = mempty { asn1dAny = True+                    , asn1dContent = \_ -> fail s+                    }++toBinaryGet :: ASN1Decode x -> Get x+toBinaryGet dec+  = getTagLength BER >>= getASN1Decode dec >>= \case+      Unexpected tl -> fail ("ASN1Decode: unexpected " ++ show tl)+      UnexpectedEOF -> fail "ASN1Decode: premature end of stream"+      Consumed (Just tl) _ -> fail ("ASN1Decode: leftover " ++ show tl)+      Consumed Nothing x -> pure x++getASN1Decode :: ASN1Decode x -> Maybe TL -> Get (ASN1Res x)+getASN1Decode (ASN1Decode{..}) Nothing+  | asn1dAny  = asn1dContent Nothing+  | otherwise = pure UnexpectedEOF+getASN1Decode (ASN1Decode{..}) (Just tl@(t,_,_))+  | asn1dAny || Set.member t asn1dTags  = asn1dContent (Just tl)+  | otherwise                           = pure (Unexpected tl)++----------------------------------------------------------------------------+-- simple ASN.1 EDSL++-- bind-like transform+transformVia :: ASN1Decode x -> (x -> Either String y) -> ASN1Decode y+transformVia old f+  = old { asn1dContent = \mtl -> do+            asn1dContent old mtl >>= \case+              Consumed lo x -> case f x of+                                 Left e  -> fail e+                                 Right y -> pure (Consumed lo y)+              Unexpected u  -> pure (Unexpected u)+              UnexpectedEOF -> pure UnexpectedEOF+        }++explicit :: Tag -> ASN1Decode x -> ASN1Decode x+explicit t body = with'Constructed (show t ++ " EXPLICIT") t body++implicit :: Tag -> ASN1Decode x -> ASN1Decode x+implicit newtag old+  | Just oldtag <- asn1decodeIsSingleton old+  = mempty { asn1dTags    = Set.singleton newtag+           , asn1dContent = \case+               Just tl@(curtag,_,_) | newtag /= curtag -> pure (Unexpected tl)+               Just (_,pc,sz) -> asn1dContent old (Just (oldtag,pc,sz))+               Nothing        -> asn1dContent old Nothing+           }+  | otherwise = error "implicit applied to non-singleton ASN1Decode"++with'CHOICE :: [ASN1Decode x] -> ASN1Decode x+with'CHOICE = mconcat++with'Constructed :: forall x . String -> Tag -> ASN1Decode x -> ASN1Decode x+with'Constructed l tag body = asn1DecodeSingleton' tag go+  where+    go :: TL -> Get (ASN1Res x)+    go (_,Primitive,_) = fail (l ++ " with primitive encoding")+    go (_,Constructed,Nothing) = fail (l ++ " with indef length not supported yet")+    go (_,Constructed,Just sz) = isolate64 sz $ do+          tl' <- getTagLength BER+          getASN1Decode body tl'++with'SEQUENCE :: forall x . ASN1Decode x -> ASN1Decode x+with'SEQUENCE = with'Constructed "SEQUENCE" (Universal 16)++with'SEQUENCE_OF :: forall x . ASN1Decode x -> ASN1Decode [x]+with'SEQUENCE_OF body = asn1DecodeSingleton' (Universal 16) go+  where+    go :: TL -> Get (ASN1Res [x])+    go (_,Primitive,_)         = fail "SEQUENCE OF with primitive encoding"+    go (_,Constructed,Nothing) = fail "indef SEQUENCE OF not implemented yet"+    go (_,Constructed,Just sz) = isolate64 sz $ do+          -- NB: Get Monad+          let loop :: [x] -> Maybe TL -> Get [x]+              loop acc tl0 = do+                tl' <- case tl0 of+                         Just _  -> pure tl0+                         Nothing -> getTagLength BER+                case tl' of+                  Nothing -> pure (reverse acc)+                  Just _  -> do+                    tmp <- getASN1Decode body tl'+                    case tmp of+                      Consumed tl'' v -> loop (v:acc) tl''+                      UnexpectedEOF   -> fail "with'SEQUENCE_OF: unexpected EOF"+                      Unexpected t    -> fail ("with'SEQUENCE_OF: unexpected " ++ show t)++          Consumed Nothing <$> loop [] Nothing+++with'SET_OF :: forall x . ASN1Decode x -> ASN1Decode [x]+with'SET_OF body = asn1DecodeSingleton' (Universal 17) go+  where+    go :: TL -> Get (ASN1Res [x])+    go (_,Primitive,_)         = fail "SET OF with primitive encoding"+    go (_,Constructed,Nothing) = fail "indef SET OF not implemented yet"+    go (_,Constructed,Just sz) = isolate64 sz $ do+          -- NB: Get Monad+          let loop :: [x] -> Maybe TL -> Get [x]+              loop acc tl0 = do+                tl' <- case tl0 of+                         Just _  -> pure tl0+                         Nothing -> getTagLength BER+                case tl' of+                  Nothing -> pure (reverse acc)+                  Just _  -> do+                    tmp <- getASN1Decode body tl'+                    case tmp of+                      Consumed tl'' v -> loop (v:acc) tl''+                      UnexpectedEOF   -> fail "with'SET_OF: unexpected EOF"+                      Unexpected t    -> fail ("with'SET_OF: unexpected " ++ show t)++          Consumed Nothing <$> loop [] Nothing++++dec'BOOLEAN :: ASN1Decode Bool+dec'BOOLEAN = asn1DecodeSingleton (Universal 1) $ asPrimitive go+  where+    go 1 = do+      x <- getWord8+      case x of+        0x00 -> pure False+        0xff -> pure True+        _    -> fail "BOOLEAN must be encoded as either 0x00 or 0xFF" -- enforce DER/DER rules here+    go _ = fail "BOOLEAN with content-length not equal 1"++enc'BOOLEAN :: Bool -> ASN1Encode Word64+enc'BOOLEAN v = ASN1Encode $ \mt -> do+  _ <- putTagLength (Universal 1 `fromMaybe` mt, Primitive, Just 1)+  putWord8 (if v then 0xff else 0x00)+  pure 3++{- TODO+getPrim'Boolean :: EncodingRule -> Word64 -> Get Bool+getPrim'Boolean r sz+  | sz /= 1 = fail "boolean content shall be a single octet"+  | otherwise = do+      x <- getWord8+      case (r,x) of+        (_,0x00)   -> pure False+        (BER,_)    -> pure True+        (CER,0xff) -> pure True+        (CER,_)    -> fail "all bits shall be set in boolean TRUE encoding for CER"+        (DER,0xff) -> pure True+        (DER,_)    -> fail "all bits shall be set in boolean TRUE encoding for DER"+-}++dec'INTEGER :: ASN1Decode Integer+dec'INTEGER = asn1DecodeSingleton (Universal 2) $ asPrimitive getVarInteger++enc'INTEGER :: Integer -> ASN1Encode Word64+enc'INTEGER i = wrap'DEFINITE (Universal 2) Primitive (putVarInteger i)++dec'UInt :: forall lb ub t . (UIntBounds lb ub t, Num t) => ASN1Decode (UInt lb ub t)+dec'UInt = do+  i <- dec'INTEGER -- TODO: size-hint+  case uintFromInteger (toInteger i) of+    Left Underflow -> asn1fail "INTEGER below lower bound"+    Left Overflow  -> asn1fail "INTEGER above upper bound"+    Left _         -> asn1fail "INTEGER"+    Right v        -> pure v++enc'UInt :: forall lb ub t . (UIntBounds lb ub t, Num t, Integral t) => UInt lb ub t -> ASN1Encode Word64+enc'UInt = enc'INTEGER . toInteger . fromUInt++dec'Int64 :: ASN1Decode Int64+dec'Int64 = asn1DecodeSingleton (Universal 2) $ asPrimitive getVarInt64++enc'Int64 :: Int64 -> ASN1Encode Word64+enc'Int64 i = wrap'DEFINITE (Universal 2) Primitive (putVarInt64 i)++dec'ENUMERATED :: Enumerated enum => ASN1Decode enum+dec'ENUMERATED = asn1DecodeSingleton (Universal 10) $ asPrimitive $ \sz -> do+    i <- go sz+    maybe (fail "invalid ENUMERATED value") pure (toEnumerated i)+  where+    go 0 = fail "ENUMERATED with empty content"+    go sz+      | sz <= 8   = getVarInt64 sz+      | otherwise = fail "invalid ENUMERATED value"++enc'ENUMERATED :: Enumerated enum => enum -> ASN1Encode Word64+enc'ENUMERATED = retag (Universal 10) . enc'Int64 . fromEnumerated++-- | Only for non-sparse 'Enum's+dec'BoundedEnum :: forall enum . (Bounded enum, Enum enum) => ASN1Decode enum+dec'BoundedEnum = do+    i <- dec'ENUMERATED+    unless (i `inside` (lb,ub)) $ asn1fail "invalid ENUMERATED value"+    pure (toEnum i)+  where+    lb = fromEnum (minBound :: enum)+    ub = fromEnum (maxBound :: enum)++enc'BoundedEnum :: Enum enum => enum -> ASN1Encode Word64+enc'BoundedEnum v = enc'ENUMERATED (fromIntegral (fromEnum v) :: Int64)++dec'NULL :: ASN1Decode ()+dec'NULL = asn1DecodeSingleton (Universal 5) $ asPrimitive go+  where+    go 0 = pure ()+    go _ = fail "NULL with content-length not equal 0"++enc'NULL :: ASN1Encode Word64+enc'NULL = ASN1Encode $ \mt -> putTagLength (Universal 5 `fromMaybe` mt, Primitive, Just 0)+++dec'OCTETSTRING :: ASN1Decode ByteString+dec'OCTETSTRING = asn1DecodeSingleton (Universal 4) $ asPrimitive go+  where+    go sz+      | Just sz' <- intCastMaybe sz = Bin.getByteString sz'+      | otherwise = fail "OCTET STRING too large for this implementation"++enc'OCTETSTRING :: ByteString -> ASN1Encode Word64+enc'OCTETSTRING bs = ASN1Encode $ \mt -> do+  let cl = fromIntegral (BS.length bs)+  hl <- putTagLength (Universal 4 `fromMaybe` mt, Primitive, Just cl)+  Bin.putByteString bs+  pure (hl + cl)++wrap'DEFINITE :: Tag -> TagPC -> PutM Word64 -> ASN1Encode Word64+wrap'DEFINITE t0 pc body = ASN1Encode $ \mt -> do+  let (cl, lbs) = Bin.runPutM body+  hl <- putTagLength (fromMaybe t0 mt, pc, Just cl)+  Bin.putLazyByteString lbs+  pure (hl+cl)+++retag :: Tag -> ASN1Encode a -> ASN1Encode a+retag newtag (ASN1Encode old) = ASN1Encode (\mt -> old (mt <|> Just newtag))++wraptag :: Tag -> ASN1Encode Word64 -> ASN1Encode Word64+wraptag newtag (ASN1Encode old) = wrap'DEFINITE newtag Constructed (old Nothing)++----------------------------------------------------------------------------++-- | ASN.1 @IMPLICIT@ Annotation+newtype IMPLICIT (tag :: TagK) x = IMPLICIT x+  deriving (Generic,NFData,IsString,Num,Show,Eq,Ord,Enum)++instance Newtype (IMPLICIT tag x) x++-- | ASN.1 @EXPLICIT@ Annotation+newtype EXPLICIT (tag :: TagK) x = EXPLICIT x+  deriving (Generic,NFData,IsString,Num,Show,Eq,Ord,Enum)++instance Newtype (EXPLICIT tag x) x++-- | ASN.1 @ENUMERATED@ Annotation+newtype ENUMERATED x = ENUMERATED x+  deriving (Generic,NFData,Num,Show,Eq,Ord,Enum)++instance Newtype (ENUMERATED x) x++----------------------------------------------------------------------------++class ASN1 t where+  asn1decode :: ASN1Decode t+  asn1decode = with'Constructed "SEQUENCE" (asn1defTag (Proxy :: Proxy t)) asn1decodeCompOf++  asn1decodeCompOf :: ASN1Decode t+  asn1decodeCompOf = asn1fail "asn1decodeCompOf not implemented for type"++  asn1encode :: t -> ASN1Encode Word64+  asn1encode = wraptag (asn1defTag (Proxy :: Proxy t)) . asn1encodeCompOf++  -- constructed contents+  asn1encodeCompOf :: t -> ASN1Encode Word64+  asn1encodeCompOf = error "asn1encode(CompOf) not implemented for type"++  -- default-tag+  asn1defTag :: Proxy t -> Tag+  asn1defTag _ = Universal 16++  {-# MINIMAL (asn1decode | asn1decodeCompOf), (asn1encode | asn1encodeCompOf) #-}++instance (ASN1 t1, ASN1 t2) => ASN1 (t1,t2) where+  asn1encodeCompOf (v1,v2) = enc'SEQUENCE_COMPS [asn1encode v1, asn1encode v2]+  asn1decodeCompOf = (,) <$> asn1decode <*> asn1decode++instance (ASN1 t1, ASN1 t2, ASN1 t3) => ASN1 (t1,t2,t3) where+  asn1encodeCompOf (v1,v2,v3) = enc'SEQUENCE_COMPS [asn1encode v1, asn1encode v2, asn1encode v3]+  asn1decodeCompOf = (,,) <$> asn1decode <*> asn1decode <*> asn1decode++instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4) => ASN1 (t1,t2,t3,t4) where+  asn1encodeCompOf (v1,v2,v3,v4) = enc'SEQUENCE_COMPS [asn1encode v1, asn1encode v2, asn1encode v3, asn1encode v4]+  asn1decodeCompOf = (,,,) <$> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode++instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5) => ASN1 (t1,t2,t3,t4,t5) where+  asn1encodeCompOf (v1,v2,v3,v4,v5) = enc'SEQUENCE_COMPS [asn1encode v1, asn1encode v2, asn1encode v3, asn1encode v4, asn1encode v5]+  asn1decodeCompOf = (,,,,) <$> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode++instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5, ASN1 t6) => ASN1 (t1,t2,t3,t4,t5,t6) where+  asn1encodeCompOf (v1,v2,v3,v4,v5,v6) = enc'SEQUENCE_COMPS [asn1encode v1, asn1encode v2, asn1encode v3, asn1encode v4, asn1encode v5, asn1encode v6]+  asn1decodeCompOf = (,,,,,) <$> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode++instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5, ASN1 t6, ASN1 t7) => ASN1 (t1,t2,t3,t4,t5,t6,t7) where+  asn1encodeCompOf (v1,v2,v3,v4,v5,v6,v7) = enc'SEQUENCE_COMPS [asn1encode v1, asn1encode v2, asn1encode v3, asn1encode v4, asn1encode v5, asn1encode v6, asn1encode v7]+  asn1decodeCompOf = (,,,,,,) <$> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode++-- | ASN.1 @OCTET STRING@ type+type OCTET_STRING = ByteString++instance ASN1 ByteString where+  asn1defTag _ = Universal 4+  asn1decode = dec'OCTETSTRING+  asn1encode = enc'OCTETSTRING++instance ASN1 SBS.ShortByteString where+  asn1defTag _ = Universal 4+  asn1decode = SBS.toShort <$> dec'OCTETSTRING+  asn1encode = enc'OCTETSTRING . SBS.fromShort -- TODO: optimize++instance ASN1 ShortText where+  asn1defTag _ = Universal 4+  asn1decode = do+    bs <- dec'OCTETSTRING+    maybe (asn1fail "OCTECT STRING contained invalid UTF-8") pure (TS.fromByteString bs)+  asn1encode = asn1encode . TS.toShortByteString++type BOOLEAN = Bool++instance ASN1 Bool where+  asn1defTag _ = Universal 1+  asn1decode = dec'BOOLEAN+  asn1encode = enc'BOOLEAN++type OPTIONAL x = Maybe x++instance ASN1 t => ASN1 (Maybe t) where+  asn1defTag _ = asn1defTag (Proxy :: Proxy t)+  asn1decode = with'OPTIONAL asn1decode++  asn1encode Nothing  = empty'ASN1Encode+  asn1encode (Just v) = asn1encode v++instance Enumerated t => ASN1 (ENUMERATED t) where+  asn1defTag _ = Universal 10+  asn1decode = ENUMERATED <$> dec'ENUMERATED+  asn1encode (ENUMERATED v) = enc'ENUMERATED v++instance ASN1 t => ASN1 [t] where+  asn1decode = with'SEQUENCE_OF asn1decode+  asn1encode = enc'SEQUENCE . map asn1encode++-- | @SEQUENCE SIZE (1..MAX) OF@+instance ASN1 t => ASN1 (NonEmpty t) where+  asn1decode = asn1decode >>= \case+                 []   -> asn1fail "SEQUENCE must be non-empty"+                 x:xs -> pure (x :| xs)++  asn1encode (x :| xs) = asn1encode (x:xs)++-- | ASN.1 @SET SIZE (1..MAX) OF@ type+newtype SET1 x = SET1 (NonEmpty x)+  deriving (Generic,NFData,Show,Eq,Ord)++instance Newtype (SET1 x) (NonEmpty x)++instance ASN1 t => ASN1 (SET1 t) where+  asn1defTag _ = Universal 17+  asn1decode = asn1decode >>= \case+                 SET [] -> asn1fail "SET must be non-empty"+                 SET (x:xs) -> pure (SET1 (x :| xs))++  asn1encode (SET1 (x :| xs)) = asn1encode (SET (x:xs))++-- | ASN.1 @SET OF@ type+newtype SET x = SET [x]+  deriving (Generic,NFData,Show,Eq,Ord)++instance Newtype (SET x) [x]++instance ASN1 t => ASN1 (SET t) where+  asn1defTag _ = Universal 17+  asn1decode = SET <$> with'SET_OF asn1decode+  asn1encode (SET vs) = enc'SET (map asn1encode vs)++instance ASN1 Integer where+  asn1defTag _ = Universal 2+  asn1decode = dec'INTEGER+  asn1encode = enc'INTEGER++instance ASN1 Int64 where+  asn1defTag _ = Universal 2+  asn1decode = dec'Int64+  asn1encode = enc'Int64++instance (UIntBounds lb ub t, Integral t) => ASN1 (UInt lb ub t) where+  asn1defTag _ = Universal 2+  asn1decode = dec'UInt+  asn1encode = enc'UInt++instance forall tag t . (KnownTag tag, ASN1 t) => ASN1 (IMPLICIT tag t) where+  asn1defTag _ = tagVal (Proxy :: Proxy tag)+  asn1decode = IMPLICIT <$> implicit (tagVal (Proxy :: Proxy tag)) asn1decode+  asn1encode (IMPLICIT v) = retag (tagVal (Proxy :: Proxy tag)) (asn1encode v)++instance forall tag t . (KnownTag tag, ASN1 t) => ASN1 (EXPLICIT tag t) where+  asn1defTag _ = tagVal (Proxy :: Proxy tag)+  asn1decode = EXPLICIT <$> explicit (tagVal (Proxy :: Proxy tag)) asn1decode+  asn1encode (EXPLICIT v) = wraptag (tagVal (Proxy :: Proxy tag)) (asn1encode v)++-- | ASN.1 @NULL@ type+type NULL = ()++-- | denotes @NULL@+instance ASN1 () where+  asn1defTag _ = Universal 5+  asn1decode = dec'NULL+  asn1encode () = enc'NULL++-- | This represents a @BOOLEAN DEFAULT FALSE@ that is only ever serialized as 'True' (hence why its only inhabitant is a /true/ value)+--+-- This must be 'Maybe'-wrapped to make any sense; the table below shows the mapping between 'Bool' values and this construct.+--+-- +---------+-----------------------------------++-- | 'Bool'  | @'Maybe' 'BOOLEAN_DEFAULT_FALSE'@ |+-- +=========+===================================++-- | 'False' | 'Nothing'                         |+-- +---------+-----------------------------------++-- | 'True'  | @'Just' 'BOOL_TRUE'@              |+-- +---------+-----------------------------------++--+data BOOLEAN_DEFAULT_FALSE = BOOL_TRUE+  deriving (Generic,Eq,Ord,Show)++instance NFData BOOLEAN_DEFAULT_FALSE where+  rnf BOOL_TRUE = ()++instance ASN1 BOOLEAN_DEFAULT_FALSE where+  asn1defTag _ = Universal 1 -- not used+  asn1decode = dec'BOOLEAN `transformVia`+               bool (Left "FALSE encountered despite 'BOOLEAN DEFAULT FALSE'") (Right BOOL_TRUE)+  asn1encode BOOL_TRUE = asn1encode True

@@ -0,0 +1,336 @@+-- Copyright (c) 2018-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 BangPatterns               #-}+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeOperators              #-}++module Data.ASN1.Prim+    ( TagPC(..)+    , TL+    , Tag(..)+    , TagK(..), KnownTag(..)+    , EncodingRule(..)+    , isolate64++    , putTagLength+    , getTagLength++    , getVarInt64+    , putVarInt64+    , asPrimitive++    , getVarInteger+    , putVarInteger+    ) where++import           Common++import           Data.Binary     as Bin+import           Data.Binary.Get as Bin+import           Data.Binary.Put as Bin++data TagPC+  = Primitive+  | Constructed+  deriving (Enum,Eq,Show)++data EncodingRule+  = BER+  | CER+  | DER+  deriving Eq++isolate64 :: Word64 -> Get a -> Get a+isolate64 sz64 act+  | Just sz <- intCastMaybe sz64 = Bin.isolate sz act+  | otherwise = fail "isolate64: exceeding supported limits"++type TL = (Tag, TagPC, Maybe Word64)++getTagLength :: EncodingRule -> Get (Maybe TL)+getTagLength r = do+  eof <- isEmpty++  if eof+    then pure Nothing+    else Just <$> do+      (t,pc) <- getTag r+      l <- getLength (r /= BER)++      case (r,l,pc) of+        (_,Nothing,Primitive)    -> fail "indefinite length not allowed for primitive encoding"+        (DER,Nothing,_)          -> fail "indefinite length encoding not allowed by DER"+        (CER,Just _,Constructed) -> fail "definite length not allowed for constructed encoding by CER"+        _                        -> pure ()++      pure (t,pc,l)++putTagLength :: TL -> PutM Word64+putTagLength (_,Primitive,Nothing) = error "indefinite length not allowed for primitive encoding"+putTagLength (t,pc,msz)            = (+) <$> putTag t pc <*> putLength msz++getTag :: EncodingRule -> Get (Tag, TagPC)+getTag _ = do+  b0 <- getWord8+  let !pc = if testBit b0 5 then Constructed else Primitive+      n0 = b0 .&. 0x1f++  !tn <- case n0 of+          0x1f -> getXTagNum -- long-form tag-number+          _    -> pure (fromIntegral n0)++  case b0 .&. 0xc0 of+    0x00 -> pure (Universal   tn, pc)+    0x40 -> pure (Application tn, pc)+    0x80 -> pure (Contextual  tn, pc)+    0xc0 -> pure (Private     tn, pc)+    _    -> fail "the impossible happened"++putTag :: Tag -> TagPC -> PutM Word64+putTag t pc = do+  when (tagNum t >= 31) $ error "putTag: FIXME"++  let w8_cls = case t of+                 Universal   _ -> 0x00+                 Application _ -> 0x40+                 Contextual  _ -> 0x80+                 Private     _ -> 0xc0++      w8_pc  = case pc of+                 Constructed -> 0x20+                 Primitive   -> 0x00++      w8_tn  = fromIntegral (tagNum t)++  putWord8 (w8_cls .|. w8_pc .|. w8_tn)+  pure 1++getXTagNum :: Get Word64+getXTagNum = do+    (more0,n0) <- getWord7+    let n0' = fromIntegral n0++    when (n0' == 0) $+      fail "lower 7 bits of the first subsequent tag-number octet shall not all be zero"++    if more0+      then go n0'+      else pure n0'++  where+    go :: Word64 -> Get Word64+    go !acc = do+      (mo,o7) <- getWord7+      let acc' = (acc `shiftL` 7) .|. fromIntegral o7++      when (acc >= 0x0200000000000000) $+        fail "tag number exceeds 64bit range" -- TODO: investigate whether there's ASN.1 schemas requiring larger tag-numbers++      if mo+        then go acc'+        else pure $! acc'++getWord7 :: Get (Bool,Word8)+getWord7 = do+  x <- getWord8+  let n = x .&. 0x7f+      more = x /= n+  pure (more, n)++getLength :: Bool -> Get (Maybe Word64) -- 'Nothing' denotes indefinite+getLength minimal = do+    xb7 <- getWord7+    case xb7 of+      -- definite short-form+      (False,n)   -> pure $! Just $! fromIntegral n++      -- indefinite+      (True,0)    -> pure Nothing++      -- reserved+      (True,0x7f) -> fail "length octet with reserved value 0xff encountered"++      -- definite long-form+      (True,sz)   -> Just <$> go sz 0+  where+    go :: Word8 -> Word64 -> Get Word64+    go 0 acc+      | minimal, acc < 0x1f  = fail "length not encoded minimally"+      | otherwise            = pure acc+    go sz acc = do+      when (acc >= 0x0100000000000000) $+        fail "length exceeds 64bit quantity"++      x <- getWord8++      let acc' = (acc `shiftL` 8) .|. fromIntegral x+      when (minimal && acc == 0 && x == 0) $+        fail "length not encoded minimally"++      go (sz-1) acc'++putLength :: Maybe Word64 -> PutM Word64+putLength Nothing = putWord8 0x80 *> pure 1+putLength (Just sz)+  | sz < 0x80 = putWord8 (fromIntegral sz) *> pure 1+  | otherwise = do+      let w8s = splitWord64 sz+          n   = length w8s++      putWord8 (0x80 + fromIntegral n)+      mapM_ putWord8 w8s+      pure (1 + fromIntegral n)+++asPrimitive :: (Word64 -> Get x) -> TL -> Get x+asPrimitive _ (_,_,Nothing)         = fail "indefinite length not allowed"+asPrimitive _ (_,Constructed,_)     = fail "must be primitive"+asPrimitive f (_,Primitive,Just sz) = f sz++----------------------------------------------------------------------------++getInt24be :: Get Int32+getInt24be = do+  hi <- getInt8+  lo <- getWord16be+  pure $! (fromIntegral hi `shiftL` 16) + fromIntegral lo++getInt40be :: Get Int64+getInt40be = do+  hi <- getInt8+  lo <- getWord32be+  pure $! (fromIntegral hi `shiftL` 32) + fromIntegral lo++getInt48be :: Get Int64+getInt48be = do+  hi <- getInt16be+  lo <- getWord32be+  pure $! (fromIntegral hi `shiftL` 32) + fromIntegral lo++getInt56be :: Get Int64+getInt56be = do+  hi <- getInt24be+  lo <- getWord32be+  pure $! (fromIntegral hi `shiftL` 32) + fromIntegral lo+++getVarInt64 :: Word64 -> Get Int64+getVarInt64 = \case+  0 -> fail "invalid zero-sized INTEGER"+  1 -> fromIntegral <$> getInt8+  2 -> fromIntegral <$> getInt16be+  3 -> fromIntegral <$> getInt24be+  4 -> fromIntegral <$> getInt32be+  5 ->                  getInt40be+  6 ->                  getInt48be+  7 ->                  getInt56be+  8 ->                  getInt64be+  _ -> fail "INTEGER too large for type"++getVarInteger :: Word64 -> Get Integer+getVarInteger sz+  | sz <= 8 = toInteger <$> getVarInt64 sz+  | otherwise = fail "INTEGER: FIXME/TODO"+++putVarInt64 :: Int64 -> PutM Word64+putVarInt64 i = do+    mapM_ Bin.putWord8 w8s+    pure (fromIntegral $ length w8s)+  where+    w8s = splitInt64 i+++putVarInteger :: Integer -> PutM Word64+putVarInteger j+  | Just i <- intCastMaybe j = putVarInt64 i+  | otherwise = error "putVarInteger: FIXME"++splitInt64 :: Int64 -> [Word8]+splitInt64 i+  | i >= 0x80 = goP i False []+  | i < -0x80 = goN i True  []+  | otherwise = [fromIntegral i]+  where+    goP 0 False acc = acc+    goP 0 True  acc = 0x00 : acc+    goP j _  acc = goP (j `shiftR` 8) (w8 >= 0x80) (w8 : acc)+      where w8 = fromIntegral (j .&. 0xff)++    goN (-1) True  acc = acc+    goN (-1) False acc = 0xff : acc+    goN j _        acc = goN (j `shiftR` 8) (w8 >= 0x80) (w8 : acc)+      where w8 = fromIntegral (j .&. 0xff)+++splitWord64 :: Word64 -> [Word8]+splitWord64 i+  | i > 0xff  = go i []+  | otherwise = [fromIntegral i]+  where+    go 0 acc = acc+    go j acc = go (j `shiftR` 8) (w8 : acc)+      where w8 = fromIntegral (j .&. 0xff)+++----------------------------------------------------------------------------++-- | ASN.1 Tag+data Tag = Universal   { tagNum :: !Word64 }+         | Application { tagNum :: !Word64 }+         | Contextual  { tagNum :: !Word64 }+         | Private     { tagNum :: !Word64 }+         deriving (Eq,Ord)++instance Show Tag where+  show = \case+     Universal n   -> "[UNIVERSAL "   ++ show n ++ "]"+     Application n -> "[APPLICATION " ++ show n ++ "]"+     Contextual n  -> "["             ++ show n ++ "]"+     Private n     -> "[PRIVATE "     ++ show n ++ "]"++----------------------------------------------------------------------------++-- | Type-level promoted 'Tag'+data TagK = UNIVERSAL   Nat+          | APPLICATION Nat+          | CONTEXTUAL  Nat+          | PRIVATE     Nat++class KnownTag (tag :: TagK) where+  tagVal :: Proxy tag -> Tag++instance forall n . (KnownNat n) => KnownTag ('UNIVERSAL n) where+  tagVal _ = Universal (fromIntegral $ natVal (Proxy :: Proxy n))++instance forall n . (KnownNat n) => KnownTag ('APPLICATION n) where+  tagVal _ = Application (fromIntegral $ natVal (Proxy :: Proxy n))++instance forall n . (KnownNat n) => KnownTag ('CONTEXTUAL n) where+  tagVal _ = Contextual (fromIntegral $ natVal (Proxy :: Proxy n))++instance forall n . (KnownNat n) => KnownTag ('PRIVATE n) where+  tagVal _ = Private (fromIntegral $ natVal (Proxy :: Proxy n))++----------------------------------------------------------------------------

@@ -0,0 +1,199 @@+-- Copyright (c) 2018-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 ConstraintKinds      #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE KindSignatures       #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Int.Subtypes+    ( UInt(..), toUInt, fromUInt, uintFromInteger+    , SInt(..), toSInt, fromSInt, sintFromInteger++    , UIntBounds+    , SIntBounds++      -- helpers+    , IsBelowMaxBound+    , IsAboveMinBoundNeg+    ) where++import           Common++import           Data.Coerce (coerce)++-- | Unsigned integer sub-type+newtype UInt (lb :: Nat) (ub :: Nat) t = UInt t+  deriving (Eq,Ord)++-- | Signed integer sub-type+--+-- __NOTE__: Due to lack of negative type-level integer literals the+-- lower bound is negated, i.e. it expresses a negative magnitude+newtype SInt (nlb :: Nat) (ub :: Nat) t = SInt t+  deriving (Eq,Ord)++-- | Coerce integer sub-type into its base-type+fromUInt :: UInt lb ub t -> t+fromUInt (UInt i) = i++-- | Coerce integer sub-type into its base-type+fromSInt :: SInt nlb ub t -> t+fromSInt (SInt i) = i++instance forall lb ub t . NFData t => NFData (UInt lb ub t) where+  rnf = coerce (rnf :: t -> ())++instance forall lb ub t . NFData t => NFData (SInt lb ub t) where+  rnf = coerce (rnf :: t -> ())++instance forall lb ub t . Show t => Show (UInt lb ub t) where+  show      = coerce (show :: t -> String)+  showsPrec = coerce (showsPrec :: Int -> t -> ShowS)++instance forall nlb ub t . Show t => Show (SInt nlb ub t) where+  show      = coerce (show :: t -> String)+  showsPrec = coerce (showsPrec :: Int -> t -> ShowS)++-- | Constraint encoding type-level invariants for 'UInt'+type UIntBounds lb ub t = ( KnownNat lb, KnownNat ub, lb <= ub+                          , IsBelowMaxBound ub (IntBaseType t) ~ 'True)++-- | Constraint encoding type-level invariants for 'SInt'+type SIntBounds nlb ub t = ( KnownNat nlb, KnownNat ub+                          , IsAboveMinBoundNeg nlb (IntBaseType t) ~ 'True+                          , IsBelowMaxBound ub (IntBaseType t) ~ 'True)++type family IsBelowMaxBound (n :: Nat) (t :: IntBaseTypeK) :: Bool where+  IsBelowMaxBound n ('FixedWordTag b) = n+1 <=? (2^b)+  IsBelowMaxBound n ('FixedIntTag b)  = n+1 <=? (2^(b-1))+  IsBelowMaxBound n 'BigIntTag        = 'True+  IsBelowMaxBound n 'BigWordTag       = 'True++type family IsAboveMinBoundNeg (n :: Nat) (t :: IntBaseTypeK) :: Bool where+  IsAboveMinBoundNeg n ('FixedWordTag b) = n <=? 0+  IsAboveMinBoundNeg n ('FixedIntTag b)  = n <=? (2^(b-1))+  IsAboveMinBoundNeg n 'BigIntTag        = 'True+  IsAboveMinBoundNeg n 'BigWordTag       = n <=? 0++instance forall lb ub t . (UIntBounds lb ub t, Num t) => Bounded (UInt lb ub t) where+  minBound = UInt $ fromInteger (natVal (Proxy :: Proxy lb))+  maxBound = UInt $ fromInteger (natVal (Proxy :: Proxy ub))++instance forall nlb ub t . (SIntBounds nlb ub t, Num t) => Bounded (SInt nlb ub t) where+  minBound = SInt $ fromInteger (-natVal (Proxy :: Proxy nlb))+  maxBound = SInt $ fromInteger (natVal (Proxy :: Proxy ub))++----------------------------------------------------------------------------++uintFromInteger :: forall lb ub t . (UIntBounds lb ub t, Num t) => Integer -> Either ArithException (UInt lb ub t)+uintFromInteger i+  | i < natVal (Proxy :: Proxy lb) = Left Underflow+  | i > natVal (Proxy :: Proxy ub) = Left Overflow+  | otherwise                      = Right i'+  where+    i' = UInt (fromInteger i) :: UInt lb ub t++-- | Try to coerce a base-type into its 'UInt' sub-type+--+-- If out of range, @'Left' 'Underflow'@ or @'Right' 'Overflow'@ will be returned.+toUInt :: forall lb ub t . (UIntBounds lb ub t, Num t, Ord t) => t -> Either ArithException (UInt lb ub t)+toUInt i+  | i' < minBound = Left Underflow+  | i' > maxBound = Left Overflow+  | otherwise     = Right i'+  where+    i' = UInt i :: UInt lb ub t++toUInt' :: forall lb ub t . (UIntBounds lb ub t, Num t, Ord t) => t -> UInt lb ub t+toUInt' = either throw id . toUInt++instance forall lb ub t . (UIntBounds lb ub t, Integral t, Ord t) => Num (UInt lb ub t) where+  fromInteger     = either throw id . uintFromInteger++  UInt 0 * _      = UInt 0+  UInt 1 * y      = y+  _      * UInt 0 = UInt 0+  x      * UInt 1 = x+  UInt x * UInt y = fromInteger (toInteger x * toInteger y)++  UInt 0 + y      = y+  x      + UInt 0 = x+  UInt x + UInt y = fromInteger (toInteger x + toInteger y)++  x      - UInt 0 = x+  UInt 0 - y      = negate y+  UInt x - UInt y = fromInteger (toInteger x - toInteger y)++  negate (UInt 0) = UInt 0+  negate (UInt _) = throw Underflow++  abs             = id++  signum (UInt 0) = UInt 0+  signum (UInt _) = toUInt' 1++----------------------------------------------------------------------------++sintFromInteger :: forall nlb ub t . (SIntBounds nlb ub t, Num t) => Integer -> Either ArithException (SInt nlb ub t)+sintFromInteger i+  | i < -natVal (Proxy :: Proxy nlb) = Left Underflow+  | i >  natVal (Proxy :: Proxy ub)  = Left Overflow+  | otherwise                        = Right i'+  where+    i' = SInt (fromInteger i) :: SInt nlb ub t++-- | Try to coerce a base-type into its 'SInt' sub-type+--+-- If out of range, @'Left' 'Underflow'@ or @'Right' 'Overflow'@ will be returned.+toSInt :: forall nlb ub t . (SIntBounds nlb ub t, Num t, Ord t) => t -> Either ArithException (SInt nlb ub t)+toSInt i+  | i' < minBound = Left Underflow+  | i' > maxBound = Left Overflow+  | otherwise     = Right i'+  where+    i' = SInt i :: SInt nlb ub t++toSInt' :: forall nlb ub t . (SIntBounds nlb ub t, Num t, Ord t) => t -> SInt nlb ub t+toSInt' = either throw id . toSInt++instance forall nlb ub t . (SIntBounds nlb ub t, Integral t, Ord t) => Num (SInt nlb ub t) where+  fromInteger     = either throw id . sintFromInteger++  SInt 0 * _      = SInt 0+  SInt 1 * y      = y+  _      * SInt 0 = SInt 0+  x      * SInt 1 = x+  SInt x * SInt y = fromInteger (toInteger x * toInteger y)++  SInt 0 + y      = y+  x      + SInt 0 = x+  SInt x + SInt y = fromInteger (toInteger x + toInteger y)++  x      - SInt 0 = x+  SInt 0 - y      = negate y+  SInt x - SInt y = fromInteger (toInteger x - toInteger y)++  negate (SInt 0) = SInt 0+  negate (SInt x) = fromInteger (toInteger x)++  abs    (SInt x) = fromInteger (abs (toInteger x))++  signum (SInt 0) = SInt 0+  signum (SInt x) = toSInt' (signum x)

@@ -0,0 +1,1180 @@+-- 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 DeriveGeneric              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE TypeOperators              #-}++-- | 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'+-- * 'Data.Binary.Get.runGetIncremental'+--+-- are most useful.+--+module LDAPv3+    ( -- * LDAPv3 Protocol data structures+      --+      -- | The Haskell data structures defined in this module closely follow the protocol specification as laid out in <https://tools.ietf.org/html/rfc4511 RFC4511>.+      --+      -- For convenience, the normative <https://en.wikipedia.org/wiki/ASN.1 ASN.1> definitions for each Haskell data type are quoted.++      -- ** Common Elements (<https://tools.ietf.org/html/rfc4511#section-4.1 RFC4511 Section 4.1>)++      -- 4.1.1.  Message Envelope+      LDAPMessage(..)+    , MessageID(..)+    , MaxInt+    , ProtocolOp(..)++      -- 4.1.2.  String Types+    , LDAPString+    , LDAPOID+      -- 4.1.3.  Distinguished Name and Relative Distinguished Name+    , LDAPDN+    , RelativeLDAPDN+      -- 4.1.4.  Attribute Descriptions+    , AttributeDescription+      -- 4.1.5.  Attribute Value+    , AttributeValue+      -- 4.1.6.  Attribute Value Assertion+    , AttributeValueAssertion(..)+    , AssertionValue+      -- 4.1.7.  Attribute and PartialAttribute+    , PartialAttribute(..)+    , Attribute(..)+      -- 4.1.8.  Matching Rule Identifier+    , MatchingRuleId+      -- 4.1.9.  Result Message+    , LDAPResult(..)+    , ResultCode(..)+      -- 4.1.10.  Referral+    , Referral+    , URI+      -- 4.1.11.  Controls+    , Controls+    , Control(..)++      -- ** Bind Operation  (<https://tools.ietf.org/html/rfc4511#section-4.2 RFC4511 Section 4.2>)++    , BindRequest(..)+    , AuthenticationChoice(..)+    , SaslCredentials(..)+    , BindResponse(..)++      -- ** Unbind Operation  (<https://tools.ietf.org/html/rfc4511#section-4.3 RFC4511 Section 4.3>)++    , UnbindRequest++      -- ** Unsolicited Notification  (<https://tools.ietf.org/html/rfc4511#section-4.4 RFC4511 Section 4.4>)+      --+      -- | Unsolicited notifications are represented by an 'ExtendedResponse' message with its 'MessageID' set to @0@.++      -- ** Search Operation  (<https://tools.ietf.org/html/rfc4511#section-4.5 RFC4511 Section 4.5>)++    , SearchRequest(..)+    , Scope(..)+    , DerefAliases(..)+    , AttributeSelection+    , Filter(..)+    , SubstringFilter(..)+    , Substring(..)+    , MatchingRuleAssertion(..)++      -- *** Search Result   (<https://tools.ietf.org/html/rfc4511#section-4.5.2 RFC4511 Section 4.5.2>)++    , SearchResultEntry(..)+    , PartialAttributeList+    , SearchResultReference(..)+    , SearchResultDone++      -- ** Modify Operation   (<https://tools.ietf.org/html/rfc4511#section-4.6 RFC4511 Section 4.6>)++    , ModifyRequest(..)+    , Change(..)+    , Operation(..)+    , ModifyResponse++      -- ** Add Operation   (<https://tools.ietf.org/html/rfc4511#section-4.7 RFC4511 Section 4.7>)++    , AddRequest(..)+    , AttributeList+    , AddResponse++      -- ** Delete Operation   (<https://tools.ietf.org/html/rfc4511#section-4.8 RFC4511 Section 4.8>)++    , DelRequest+    , DelResponse++      -- ** Modify DN Operation   (<https://tools.ietf.org/html/rfc4511#section-4.9 RFC4511 Section 4.9>)++    , ModifyDNRequest(..)+    , ModifyDNResponse++      -- ** Compare Operation   (<https://tools.ietf.org/html/rfc4511#section-4.10 RFC4511 Section 4.10>)++    , CompareRequest(..)+    , CompareResponse++      -- ** Abandon Operation   (<https://tools.ietf.org/html/rfc4511#section-4.11 RFC4511 Section 4.11>)++    , AbandonRequest++      -- ** Extended Operation   (<https://tools.ietf.org/html/rfc4511#section-4.12 RFC4511 Section 4.12>)++    , ExtendedRequest(..)+    , ExtendedResponse(..)++      -- ** Intermediate Response  (<https://tools.ietf.org/html/rfc4511#section-4.13 RFC4511 Section 4.13>)++    , IntermediateResponse(..)++      -- * ASN.1 Helpers+    , NULL+    , OCTET_STRING+    , BOOLEAN_DEFAULT_FALSE(..)+    , SET(..)+    , SET1(..)++      -- ** ASN.1 type-level tagging+    , EXPLICIT(..)+    , IMPLICIT(..)+    , TagK(..)++      -- * Unsigned integer sub-type+    , UIntBounds+    , UInt+    , fromUInt+    , toUInt+    ) where++import           Common+import           Data.ASN1+import           Data.ASN1.Prim+import           Data.Int.Subtypes+import           LDAPv3.ResultCode++import qualified Data.Binary       as Bin++----------------------------------------------------------------------------+-- LDAPv3 protocol++{- | Message Envelope (<https://tools.ietf.org/html/rfc4511#section-4.1.1 RFC4511 Section 4.1.1>)++> LDAPMessage ::= SEQUENCE {+>      messageID       MessageID,+>      protocolOp      CHOICE {+>           bindRequest           BindRequest,+>           bindResponse          BindResponse,+>           unbindRequest         UnbindRequest,+>           searchRequest         SearchRequest,+>           searchResEntry        SearchResultEntry,+>           searchResDone         SearchResultDone,+>           searchResRef          SearchResultReference,+>           modifyRequest         ModifyRequest,+>           modifyResponse        ModifyResponse,+>           addRequest            AddRequest,+>           addResponse           AddResponse,+>           delRequest            DelRequest,+>           delResponse           DelResponse,+>           modDNRequest          ModifyDNRequest,+>           modDNResponse         ModifyDNResponse,+>           compareRequest        CompareRequest,+>           compareResponse       CompareResponse,+>           abandonRequest        AbandonRequest,+>           extendedReq           ExtendedRequest,+>           extendedResp          ExtendedResponse,+>           ...,+>           intermediateResponse  IntermediateResponse },+>      controls       [0] Controls OPTIONAL }++-}+data LDAPMessage = LDAPMessage+  { _LDAPMessage'messageID  :: MessageID+  , _LDAPMessage'protocolOp :: ProtocolOp+  , _LDAPMessage'controls   :: Maybe ('CONTEXTUAL 0 `IMPLICIT` Controls)+  } deriving (Generic,Show,Eq)++-- | Encodes to\/from ASN.1 as per <https://tools.ietf.org/html/rfc4511#section-5.1 RFC4511 Section 5.1>+instance Bin.Binary LDAPMessage where+  put = void . toBinaryPut . asn1encode+  get = toBinaryGet asn1decode++instance ASN1 LDAPMessage where+  asn1decodeCompOf = LDAPMessage <$> asn1decode <*> asn1decode <*> asn1decode+  asn1encodeCompOf (LDAPMessage v1 v2 v3) = asn1encodeCompOf (v1,v2,v3)++{- | Message ID (<https://tools.ietf.org/html/rfc4511#section-4.1.1.1 RFC4511 Section 4.1.1.1>)++> MessageID ::= INTEGER (0 ..  maxInt)++-}+newtype MessageID = MessageID (UInt 0 MaxInt Int32)+                  deriving (Generic,NFData,Ord,Bounded,ASN1,Show,Eq)++{- | LDAPv3 protocol ASN.1 constant as per <https://tools.ietf.org/html/rfc4511#section-4.1.1 RFC4511 Section 4.1.1>++> maxInt INTEGER ::= 2147483647 -- (2^^31 - 1)++-}+type MaxInt = 2147483647++-- | @CHOICE@ type inlined in @LDAPMessage.protocolOp@  (<https://tools.ietf.org/html/rfc4511#section-4.1.1 RFC4511 Section 4.1.1>)+--+data ProtocolOp+  = ProtocolOp'bindRequest     BindRequest+  | ProtocolOp'bindResponse    BindResponse+  | ProtocolOp'unbindRequest   UnbindRequest+  | ProtocolOp'searchRequest   SearchRequest+  | ProtocolOp'searchResEntry  SearchResultEntry+  | ProtocolOp'searchResDone   SearchResultDone+  | ProtocolOp'searchResRef    SearchResultReference+  | ProtocolOp'modifyRequest   ModifyRequest+  | ProtocolOp'modifyResponse  ModifyResponse+  | ProtocolOp'addRequest      AddRequest+  | ProtocolOp'addResponse     AddResponse+  | ProtocolOp'delRequest      DelRequest+  | ProtocolOp'delResponse     DelResponse+  | ProtocolOp'modDNRequest    ModifyDNRequest+  | ProtocolOp'modDNResponse   ModifyDNResponse+  | ProtocolOp'compareRequest  CompareRequest+  | ProtocolOp'compareResponse CompareResponse+  | ProtocolOp'abandonRequest  AbandonRequest+  | ProtocolOp'extendedReq     ExtendedRequest+  | ProtocolOp'extendedResp    ExtendedResponse+  | ProtocolOp'intermediateResponse  IntermediateResponse+  deriving (Generic,Show,Eq)++instance NFData ProtocolOp++instance ASN1 ProtocolOp where+  asn1decode = with'CHOICE+    [ ProtocolOp'bindRequest    <$> asn1decode+    , ProtocolOp'bindResponse   <$> asn1decode+    , ProtocolOp'unbindRequest  <$> asn1decode+    , ProtocolOp'searchRequest  <$> asn1decode+    , ProtocolOp'searchResEntry <$> asn1decode+    , ProtocolOp'searchResDone  <$> asn1decode+    , ProtocolOp'searchResRef   <$> asn1decode+    , ProtocolOp'modifyRequest  <$> asn1decode+    , ProtocolOp'modifyResponse <$> asn1decode+    , ProtocolOp'addRequest     <$> asn1decode+    , ProtocolOp'addResponse    <$> asn1decode+    , ProtocolOp'delRequest     <$> asn1decode+    , ProtocolOp'delResponse    <$> asn1decode+    , ProtocolOp'modDNRequest   <$> asn1decode+    , ProtocolOp'modDNResponse  <$> asn1decode+    , ProtocolOp'compareRequest <$> asn1decode+    , ProtocolOp'compareResponse <$> asn1decode+    , ProtocolOp'abandonRequest <$> asn1decode+    , ProtocolOp'extendedReq    <$> asn1decode+    , ProtocolOp'extendedResp   <$> asn1decode+    , ProtocolOp'intermediateResponse <$> asn1decode+    ]++  asn1encode = \case+    ProtocolOp'bindRequest    v -> asn1encode v+    ProtocolOp'bindResponse   v -> asn1encode v+    ProtocolOp'unbindRequest  v -> asn1encode v+    ProtocolOp'searchRequest  v -> asn1encode v+    ProtocolOp'searchResEntry v -> asn1encode v+    ProtocolOp'searchResDone  v -> asn1encode v+    ProtocolOp'searchResRef   v -> asn1encode v+    ProtocolOp'modifyRequest  v -> asn1encode v+    ProtocolOp'modifyResponse v -> asn1encode v+    ProtocolOp'addRequest     v -> asn1encode v+    ProtocolOp'addResponse    v -> asn1encode v+    ProtocolOp'delRequest     v -> asn1encode v+    ProtocolOp'delResponse    v -> asn1encode v+    ProtocolOp'modDNRequest   v -> asn1encode v+    ProtocolOp'modDNResponse  v -> asn1encode v+    ProtocolOp'compareRequest v -> asn1encode v+    ProtocolOp'compareResponse v -> asn1encode v+    ProtocolOp'abandonRequest v -> asn1encode v+    ProtocolOp'extendedReq    v -> asn1encode v+    ProtocolOp'extendedResp   v -> asn1encode v+    ProtocolOp'intermediateResponse v -> asn1encode v++----------------------------------------------------------------------------++{- | Controls  (<https://tools.ietf.org/html/rfc4511#section-4.1.11 RFC4511 Section 4.1.11>)++> Controls ::= SEQUENCE OF control Control++-}+type Controls = [Control]++{- | Control Entry  (<https://tools.ietf.org/html/rfc4511#section-4.1.11 RFC4511 Section 4.1.11>)++> Control ::= SEQUENCE {+>      controlType             LDAPOID,+>      criticality             BOOLEAN DEFAULT FALSE,+>      controlValue            OCTET STRING OPTIONAL }++-}+data Control = Control+  { _Control'controlType  :: LDAPOID+  , _Control'criticality  :: Maybe BOOLEAN_DEFAULT_FALSE+  , _Control'controlValue :: Maybe OCTET_STRING+  } deriving (Generic,Show,Eq)++instance NFData Control++instance ASN1 Control where+  asn1decodeCompOf = Control <$> asn1decode <*> asn1decode <*> asn1decode+  asn1encodeCompOf (Control v1 v2 v3) = asn1encodeCompOf (v1,v2,v3)++{- | 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 = OCTET_STRING++----------------------------------------------------------------------------++{- | Bind Request  (<https://tools.ietf.org/html/rfc4511#section-4.2 RFC4511 Section 4.2>)++> BindRequest ::= [APPLICATION 0] SEQUENCE {+>      version                 INTEGER (1 ..  127),+>      name                    LDAPDN,+>      authentication          AuthenticationChoice }++-}++data BindRequest = BindRequest+  { bindRequest'version        :: UInt 1 127 Int8+  , bindRequest'name           :: LDAPDN+  , bindRequest'authentication :: AuthenticationChoice+  } deriving (Generic,Show,Eq)++instance NFData BindRequest++instance ASN1 BindRequest where+  asn1defTag _ = Application 0+  asn1decodeCompOf = BindRequest <$> asn1decode <*> asn1decode <*> asn1decode+  asn1encodeCompOf (BindRequest v1 v2 v3) = asn1encodeCompOf (v1,v2,v3)++----------------------------------------------------------------------------++{- | See 'BindRequest'++> AuthenticationChoice ::= CHOICE {+>      simple                  [0] OCTET STRING,+>                              -- 1 and 2 reserved+>      sasl                    [3] SaslCredentials,+>      ...  }++-}+data AuthenticationChoice+  = AuthenticationChoice'simple  ('CONTEXTUAL 0 `IMPLICIT` OCTET_STRING)+  | AuthenticationChoice'sasl    ('CONTEXTUAL 3 `IMPLICIT` SaslCredentials)+  deriving (Generic,Show,Eq)++instance NFData AuthenticationChoice++instance ASN1 AuthenticationChoice where+  asn1decode = with'CHOICE+    [ AuthenticationChoice'simple <$> asn1decode+    , AuthenticationChoice'sasl   <$> asn1decode+    ]++  asn1encode = \case+    AuthenticationChoice'simple v -> asn1encode v+    AuthenticationChoice'sasl   v -> asn1encode v++{- | See 'AuthenticationChoice'++> SaslCredentials ::= SEQUENCE {+>      mechanism               LDAPString,+>      credentials             OCTET STRING OPTIONAL }++-}+data SaslCredentials = SaslCredentials+  { _SaslCredentials'mechanism   :: LDAPString+  , _SaslCredentials'credentials :: Maybe OCTET_STRING+  } deriving (Generic,Show,Eq)++instance NFData SaslCredentials++instance ASN1 SaslCredentials where+  asn1decodeCompOf = SaslCredentials <$> asn1decode <*> asn1decode+  asn1encodeCompOf (SaslCredentials v1 v2) = asn1encodeCompOf (v1,v2)++----------------------------------------------------------------------------++{- | Bind Response  (<https://tools.ietf.org/html/rfc4511#section-4.2 RFC4511 Section 4.2>)++> BindResponse ::= [APPLICATION 1] SEQUENCE {+>      COMPONENTS OF LDAPResult,+>      serverSaslCreds    [7] OCTET STRING OPTIONAL }++-}++data BindResponse = BindResponse+  { _BindResponse'LDAPResult      :: LDAPResult+  , _BindResponse'serverSaslCreds :: Maybe ('CONTEXTUAL 7 `IMPLICIT` OCTET_STRING)+  } deriving (Generic,Show,Eq)++instance NFData BindResponse++instance ASN1 BindResponse where+  asn1defTag _ = Application 1+  asn1decodeCompOf = do+    _BindResponse'LDAPResult      <- asn1decodeCompOf+    _BindResponse'serverSaslCreds <- asn1decode+    pure BindResponse{..}++  asn1encodeCompOf (BindResponse{..})+    = enc'SEQUENCE_COMPS [ asn1encodeCompOf _BindResponse'LDAPResult+                         , asn1encode       _BindResponse'serverSaslCreds+                         ]++----------------------------------------------------------------------------++{- | Unbind Operation  (<https://tools.ietf.org/html/rfc4511#section-4.3 RFC4511 Section 4.3>)++> UnbindRequest ::= [APPLICATION 2] NULL++-}+type UnbindRequest = ('APPLICATION 2 `IMPLICIT` NULL)++----------------------------------------------------------------------------++{- | Search Request  (<https://tools.ietf.org/html/rfc4511#section-4.5.1 RFC4511 Section 4.5.1>)++> SearchRequest ::= [APPLICATION 3] SEQUENCE {+>      baseObject      LDAPDN,+>      scope           ENUMERATED {+>           baseObject              (0),+>           singleLevel             (1),+>           wholeSubtree            (2),+>           ...  },+>      derefAliases    ENUMERATED {+>           neverDerefAliases       (0),+>           derefInSearching        (1),+>           derefFindingBaseObj     (2),+>           derefAlways             (3) },+>      sizeLimit       INTEGER (0 ..  maxInt),+>      timeLimit       INTEGER (0 ..  maxInt),+>      typesOnly       BOOLEAN,+>      filter          Filter,+>      attributes      AttributeSelection }++-}+data SearchRequest = SearchRequest+  { _SearchRequest'baseObject   :: LDAPDN+  , _SearchRequest'scope        :: Scope+  , _SearchRequest'derefAliases :: DerefAliases+  , _SearchRequest'sizeLimit    :: (UInt 0 MaxInt Int32)+  , _SearchRequest'timeLimit    :: (UInt 0 MaxInt Int32)+  , _SearchRequest'typesOnly    :: Bool+  , _SearchRequest'filter       :: Filter+  , _SearchRequest'attributes   :: AttributeSelection+  } deriving (Generic,Show,Eq)++instance NFData SearchRequest++{- | See 'SearchRequest'++> AttributeSelection ::= SEQUENCE OF selector LDAPString+>                -- The LDAPString is constrained to+>                -- <attributeSelector> in Section 4.5.1.8++-}+type AttributeSelection = [LDAPString]++instance ASN1 SearchRequest where+  asn1decode = implicit (Application 3) $ with'SEQUENCE $ do+    _SearchRequest'baseObject   <- asn1decode+    _SearchRequest'scope        <- asn1decode+    _SearchRequest'derefAliases <- asn1decode+    _SearchRequest'sizeLimit    <- asn1decode+    _SearchRequest'timeLimit    <- asn1decode+    _SearchRequest'typesOnly    <- asn1decode+    _SearchRequest'filter       <- asn1decode+    _SearchRequest'attributes   <- asn1decode++    pure SearchRequest{..}++  asn1encode (SearchRequest v1 v2 v3 v4 v5 v6 v7 v8)+    = retag (Application 3) $+      enc'SEQUENCE [ asn1encode v1+                   , asn1encode v2+                   , asn1encode v3+                   , asn1encode v4+                   , asn1encode v5+                   , asn1encode v6+                   , asn1encode v7+                   , asn1encode v8+                   ]++-- | See 'SearchRequest'  (<https://tools.ietf.org/html/rfc4511#section-4.5.1.2 RFC4511 Section 4.5.1.2>)+data Scope+  = Scope'baseObject+  | Scope'singleLevel+  | Scope'wholeSubtree+  deriving (Generic,Bounded,Enum,Show,Eq)++instance NFData Scope where+  rnf = rwhnf++instance ASN1 Scope where+  asn1decode = dec'BoundedEnum+  asn1encode = enc'BoundedEnum++-- | See 'SearchRequest'  (<https://tools.ietf.org/html/rfc4511#section-4.5.1.3 RFC4511 Section 4.5.1.3>)+data DerefAliases+  = DerefAliases'neverDerefAliases+  | DerefAliases'derefInSearching+  | DerefAliases'derefFindingBaseObj+  | DerefAliases'derefAlways+  deriving (Generic,Bounded,Enum,Show,Eq)++instance NFData DerefAliases where+  rnf = rwhnf++instance ASN1 DerefAliases where+  asn1decode = dec'BoundedEnum+  asn1encode = enc'BoundedEnum++{- | Search Filter  (<https://tools.ietf.org/html/rfc4511#section-4.5.1.7 RFC4511 Section 4.5.1.7>)++> Filter ::= CHOICE {+>      and             [0] SET SIZE (1..MAX) OF filter Filter,+>      or              [1] SET SIZE (1..MAX) OF filter Filter,+>      not             [2] Filter,+>      equalityMatch   [3] AttributeValueAssertion,+>      substrings      [4] SubstringFilter,+>      greaterOrEqual  [5] AttributeValueAssertion,+>      lessOrEqual     [6] AttributeValueAssertion,+>      present         [7] AttributeDescription,+>      approxMatch     [8] AttributeValueAssertion,+>      extensibleMatch [9] MatchingRuleAssertion,+>      ...  }++-}+data Filter+  = Filter'and             ('CONTEXTUAL 0 `IMPLICIT` SET1 Filter)+  | Filter'or              ('CONTEXTUAL 1 `IMPLICIT` SET1 Filter)+  | Filter'not             ('CONTEXTUAL 2 `EXPLICIT` Filter)+  | Filter'equalityMatch   ('CONTEXTUAL 3 `IMPLICIT` AttributeValueAssertion)+  | Filter'substrings      ('CONTEXTUAL 4 `IMPLICIT` SubstringFilter)+  | Filter'greaterOrEqual  ('CONTEXTUAL 5 `IMPLICIT` AttributeValueAssertion)+  | Filter'lessOrEqual     ('CONTEXTUAL 6 `IMPLICIT` AttributeValueAssertion)+  | Filter'present         ('CONTEXTUAL 7 `IMPLICIT` AttributeDescription)+  | Filter'approxMatch     ('CONTEXTUAL 8 `IMPLICIT` AttributeValueAssertion)+  | Filter'extensibleMatch ('CONTEXTUAL 9 `IMPLICIT` MatchingRuleAssertion)+  deriving (Generic,Show,Eq)++instance NFData Filter++instance ASN1 Filter where+  asn1decode = with'CHOICE+    [ Filter'and             <$> asn1decode+    , Filter'or              <$> asn1decode+    , Filter'not             <$> asn1decode+    , Filter'equalityMatch   <$> asn1decode+    , Filter'substrings      <$> asn1decode+    , Filter'greaterOrEqual  <$> asn1decode+    , Filter'lessOrEqual     <$> asn1decode+    , Filter'present         <$> asn1decode+    , Filter'approxMatch     <$> asn1decode+    , Filter'extensibleMatch <$> asn1decode+    ]++  asn1encode = \case+    Filter'and             v -> asn1encode v+    Filter'or              v -> asn1encode v+    Filter'not             v -> asn1encode v+    Filter'equalityMatch   v -> asn1encode v+    Filter'substrings      v -> asn1encode v+    Filter'greaterOrEqual  v -> asn1encode v+    Filter'lessOrEqual     v -> asn1encode v+    Filter'present         v -> asn1encode v+    Filter'approxMatch     v -> asn1encode v+    Filter'extensibleMatch v -> asn1encode v++{- | Attribute Descriptions  (<https://tools.ietf.org/html/rfc4511#section-4.1.4 RFC4511 Section 4.1.4>)++> AttributeDescription ::= LDAPString+>                         -- Constrained to <attributedescription>+>                         -- [RFC4512]++-}+type AttributeDescription = LDAPString++{- | Attribute Value  (<https://tools.ietf.org/html/rfc4511#section-4.1.5 RFC4511 Section 4.1.5>)++> AttributeValue ::= OCTET STRING++-}+type AttributeValue = OCTET_STRING++{- | Attribute Value Assertion  (<https://tools.ietf.org/html/rfc4511#section-4.1.6 RFC4511 Section 4.1.6>)++> AttributeValueAssertion ::= SEQUENCE {+>      attributeDesc   AttributeDescription,+>      assertionValue  AssertionValue }++-}+data AttributeValueAssertion = AttributeValueAssertion+  { _AttributeValueAssertion'attributeDesc  :: AttributeDescription+  , _AttributeValueAssertion'assertionValue :: AssertionValue+  } deriving (Generic,Show,Eq)++instance NFData AttributeValueAssertion++-- | > AssertionValue ::= OCTET STRING+type AssertionValue = OCTET_STRING++instance ASN1 AttributeValueAssertion where+  asn1decodeCompOf = AttributeValueAssertion <$> asn1decode <*> asn1decode+  asn1encodeCompOf (AttributeValueAssertion v1 v2) = asn1encodeCompOf (v1,v2)++{- | Substring 'Filter'  (<https://tools.ietf.org/html/rfc4511#section-4.5.1.7.2 RFC4511 Section 4.5.1.7.2>)++> SubstringFilter ::= SEQUENCE {+>      type           AttributeDescription,+>      substrings     SEQUENCE SIZE (1..MAX) OF substring CHOICE {+>           initial [0] AssertionValue,  -- can occur at most once+>           any     [1] AssertionValue,+>           final   [2] AssertionValue } -- can occur at most once+>      }++__NOTE__: The additional invariants imposed on the ordering and occurence counts of the @initial@ and @final@ entries MUST currently be enforced by the consumer of this library. Future versions of this library might change to enforce these invariants at the type-level.++Specifically, the invariant stated by the specification is:++/There SHALL be at most one @initial@ and at most one @final@ in the @substrings@ of a SubstringFilter.  If @initial@ is present, it SHALL be the first element of @substrings@.  If @final@ is present, it SHALL be the last element of @substrings@./++-}+data SubstringFilter = SubstringFilter+  { _SubstringFilter'type       :: AttributeDescription+  , _SubstringFilter'substrings :: NonEmpty Substring+  } deriving (Generic,Show,Eq)++instance NFData SubstringFilter++instance ASN1 SubstringFilter where+  asn1decodeCompOf = SubstringFilter <$> asn1decode <*> asn1decode+  asn1encodeCompOf (SubstringFilter v1 v2) = asn1encodeCompOf (v1,v2)++-- | See 'SubstringFilter'+data Substring+  = Substring'initial ('CONTEXTUAL 0 `IMPLICIT` AssertionValue) -- ^ may occur at most once; must be first element if present+  | Substring'any     ('CONTEXTUAL 1 `IMPLICIT` AssertionValue)+  | Substring'final   ('CONTEXTUAL 2 `IMPLICIT` AssertionValue) -- ^ may occur at most once; must be last element if present+  deriving (Generic,Show,Eq)++instance NFData Substring++instance ASN1 Substring where+  asn1decode = with'CHOICE+    [ Substring'initial <$> asn1decode+    , Substring'any     <$> asn1decode+    , Substring'final   <$> asn1decode+    ]++  asn1encode = \case+    Substring'initial v -> asn1encode v+    Substring'any     v -> asn1encode v+    Substring'final   v -> asn1encode v+++{- | Matching Rule Identifier  (<https://tools.ietf.org/html/rfc4511#section-4.1.8 RFC4511 Section 4.1.8>)++> MatchingRuleId ::= LDAPString++-}+type MatchingRuleId = LDAPString++{- | See 'SearchRequest' 'Filter'++> MatchingRuleAssertion ::= SEQUENCE {+>      matchingRule    [1] MatchingRuleId OPTIONAL,+>      type            [2] AttributeDescription OPTIONAL,+>      matchValue      [3] AssertionValue,+>      dnAttributes    [4] BOOLEAN DEFAULT FALSE }++-}+data MatchingRuleAssertion = MatchingRuleAssertion+  { _MatchingRuleAssertion'matchingRule :: Maybe ('CONTEXTUAL 1 `IMPLICIT` MatchingRuleId)+  , _MatchingRuleAssertion'type         :: Maybe ('CONTEXTUAL 2 `IMPLICIT` AttributeDescription)+  , _MatchingRuleAssertion'matchValue   ::       ('CONTEXTUAL 3 `IMPLICIT` AssertionValue)+  , _MatchingRuleAssertion'dnAttributes :: Maybe ('CONTEXTUAL 4 `IMPLICIT` BOOLEAN_DEFAULT_FALSE)+  } deriving (Generic,Show,Eq)++instance NFData MatchingRuleAssertion++instance ASN1 MatchingRuleAssertion where+  asn1decodeCompOf = MatchingRuleAssertion <$> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode+  asn1encodeCompOf (MatchingRuleAssertion v1 v2 v3 v4) = asn1encodeCompOf (v1,v2,v3,v4)++----------------------------------------------------------------------------++{- | Search Result Continuation Reference  (<https://tools.ietf.org/html/rfc4511#section-4.5.3 RFC4511 Section 4.5.3>)++> SearchResultReference ::= [APPLICATION 19] SEQUENCE+>                           SIZE (1..MAX) OF uri URI++-}++newtype SearchResultReference = SearchResultReference (NonEmpty URI)+  deriving (Generic,NFData,Show,Eq)++instance ASN1 SearchResultReference where+  asn1defTag _ = Application 19 -- not used+  asn1decode = SearchResultReference <$> (Application 19 `implicit` asn1decode)+  asn1encode (SearchResultReference v) = retag (Application 19) $ asn1encode v++----------------------------------------------------------------------------++{- | Search Result Entry  (<https://tools.ietf.org/html/rfc4511#section-4.5.2 RFC4511 Section 4.5.2>)++> SearchResultEntry ::= [APPLICATION 4] SEQUENCE {+>      objectName      LDAPDN,+>      attributes      PartialAttributeList }++-}+data SearchResultEntry = SearchResultEntry+  { _SearchResultEntry'objectName :: LDAPDN+  , _SearchResultEntry'attributes :: PartialAttributeList+  } deriving (Generic,Show,Eq)++instance NFData SearchResultEntry++instance ASN1 SearchResultEntry where+  asn1defTag _ = Application 4+  asn1decodeCompOf = SearchResultEntry <$> asn1decode <*> asn1decode+  asn1encodeCompOf (SearchResultEntry v1 v2) = asn1encodeCompOf (v1,v2)++{- | See 'SearchResultEntry'++> PartialAttributeList ::= SEQUENCE OF+>                      partialAttribute PartialAttribute++-}+type PartialAttributeList = [PartialAttribute]++{- | Partial Attribute  (<https://tools.ietf.org/html/rfc4511#section-4.1.7 RFC4511 Section 4.1.7>)++> PartialAttribute ::= SEQUENCE {+>      type       AttributeDescription,+>      vals       SET OF value AttributeValue }++-}+data PartialAttribute = PartialAttribute+  { _PartialAttribute'type :: AttributeDescription+  , _PartialAttribute'vals :: SET AttributeValue+  } deriving (Generic,Show,Eq)++instance NFData PartialAttribute++instance ASN1 PartialAttribute where+  asn1decodeCompOf = PartialAttribute <$> asn1decode <*> asn1decode+  asn1encodeCompOf (PartialAttribute v1 v2) = asn1encodeCompOf (v1,v2)+++{- | Attribute  (<https://tools.ietf.org/html/rfc4511#section-4.1.7 RFC4511 Section 4.1.7>)++> Attribute ::= PartialAttribute(WITH COMPONENTS {+>      ...,+>      vals (SIZE(1..MAX))})++-}+data Attribute = Attribute+  { _Attribute'type :: AttributeDescription+  , _Attribute'vals :: SET1 AttributeValue+  } deriving (Generic,Show,Eq)++instance NFData Attribute++instance ASN1 Attribute where+  asn1decodeCompOf = Attribute <$> asn1decode <*> asn1decode+  asn1encodeCompOf (Attribute v1 v2) = asn1encodeCompOf (v1,v2)++----------------------------------------------------------------------------++{- | Search Result Done  (<https://tools.ietf.org/html/rfc4511#section-4.5.2 RFC4511 Section 4.5.2>)++> SearchResultDone ::= [APPLICATION 5] LDAPResult++-}+type SearchResultDone = ('APPLICATION 5 `IMPLICIT` LDAPResult)++----------------------------------------------------------------------------++{- | Result Message  (<https://tools.ietf.org/html/rfc4511#section-4.1.9 RFC4511 Section 4.1.9>)++> LDAPResult ::= SEQUENCE {+>      resultCode         ENUMERATED {+>           success                      (0),+>           operationsError              (1),+>           protocolError                (2),+>           timeLimitExceeded            (3),+>           sizeLimitExceeded            (4),+>           compareFalse                 (5),+>           compareTrue                  (6),+>           authMethodNotSupported       (7),+>           strongerAuthRequired         (8),+>                -- 9 reserved --+>           referral                     (10),+>           adminLimitExceeded           (11),+>           unavailableCriticalExtension (12),+>           confidentialityRequired      (13),+>           saslBindInProgress           (14),+>           noSuchAttribute              (16),+>           undefinedAttributeType       (17),+>           inappropriateMatching        (18),+>           constraintViolation          (19),+>           attributeOrValueExists       (20),+>           invalidAttributeSyntax       (21),+>                -- 22-31 unused --+>           noSuchObject                 (32),+>           aliasProblem                 (33),+>           invalidDNSyntax              (34),+>                -- 35 reserved for undefined isLeaf --+>           aliasDereferencingProblem    (36),+>                -- 37-47 unused --+>           inappropriateAuthentication  (48),+>           invalidCredentials           (49),+>           insufficientAccessRights     (50),+>           busy                         (51),+>           unavailable                  (52),+>           unwillingToPerform           (53),+>           loopDetect                   (54),+>                -- 55-63 unused --+>           namingViolation              (64),+>           objectClassViolation         (65),+>           notAllowedOnNonLeaf          (66),+>           notAllowedOnRDN              (67),+>           entryAlreadyExists           (68),+>           objectClassModsProhibited    (69),+>                -- 70 reserved for CLDAP --+>           affectsMultipleDSAs          (71),+>                -- 72-79 unused --+>           other                        (80),+>           ...  },+>      matchedDN          LDAPDN,+>      diagnosticMessage  LDAPString,+>      referral           [3] Referral OPTIONAL }++-}+data LDAPResult = LDAPResult+  { _LDAPResult'resultCode        :: ResultCode+  , _LDAPResult'matchedDN         :: LDAPDN+  , _LDAPResult'diagnosticMessage :: LDAPString+  , _LDAPResult'referral          :: Maybe ('CONTEXTUAL 3 `IMPLICIT` Referral)+  } deriving (Generic,Show,Eq)++instance NFData LDAPResult++{- | Referral result code  (<https://tools.ietf.org/html/rfc4511#section-4.1.10 RFC4511 Section 4.1.10>)++> Referral ::= SEQUENCE SIZE (1..MAX) OF uri URI++-}+type Referral = ('CONTEXTUAL 3 `IMPLICIT` NonEmpty URI)++{- |++> URI ::= LDAPString     -- limited to characters permitted in+>                        -- URIs++-}+type URI = LDAPString++instance ASN1 LDAPResult where+  asn1decodeCompOf = do+    _LDAPResult'resultCode        <- asn1decode+    _LDAPResult'matchedDN         <- asn1decode+    _LDAPResult'diagnosticMessage <- asn1decode+    _LDAPResult'referral          <- asn1decode+    pure LDAPResult{..}+  asn1encodeCompOf (LDAPResult v1 v2 v3 v4) = asn1encodeCompOf (v1,v2,v3,v4)++{- | String Type  (<https://tools.ietf.org/html/rfc4511#section-4.1.2 RFC4511 Section 4.1.2>)++> LDAPString ::= OCTET STRING -- UTF-8 encoded,+>                             -- [ISO10646] characters++-}+type LDAPString = ShortText++{- | Distinguished Name  (<https://tools.ietf.org/html/rfc4511#section-4.1.3 RFC4511 Section 4.1.3>)++> LDAPDN ::= LDAPString -- Constrained to <distinguishedName>+>                       -- [RFC4514]++-}+type LDAPDN = LDAPString++{- | Relative Distinguished Name  (<https://tools.ietf.org/html/rfc4511#section-4.1.3 RFC4511 Section 4.1.3>)++> RelativeLDAPDN ::= LDAPString -- Constrained to <name-component>+>                               -- [RFC4514]++-}+type RelativeLDAPDN = LDAPString++{- | Modify Operation  (<https://tools.ietf.org/html/rfc4511#section-4.6 RFC4511 Section 4.6>)++> ModifyRequest ::= [APPLICATION 6] SEQUENCE {+>      object          LDAPDN,+>      changes         SEQUENCE OF change SEQUENCE {+>           operation       ENUMERATED {+>                add     (0),+>                delete  (1),+>                replace (2),+>                ...  },+>           modification    PartialAttribute } }++-}+data ModifyRequest = ModifyRequest+  { _ModifyRequest'object  :: LDAPDN+  , _ModifyRequest'changes :: [Change]+  } deriving (Generic,Show,Eq)++instance NFData ModifyRequest++instance ASN1 ModifyRequest where+  asn1defTag _ = Application 6+  asn1decodeCompOf = ModifyRequest <$> asn1decode <*> asn1decode+  asn1encodeCompOf (ModifyRequest v1 v2) = asn1encodeCompOf (v1,v2)++-- | See 'ModifyRequest'+data Change = Change+  { _Change'operation    :: Operation+  , _Change'modification :: PartialAttribute+  } deriving (Generic,Show,Eq)++instance NFData Change++instance ASN1 Change where+  asn1decodeCompOf = Change <$> asn1decode <*> asn1decode+  asn1encodeCompOf (Change v1 v2) = asn1encodeCompOf (v1,v2)++-- | See 'ModifyRequest' and 'Change'+data Operation+  = Operation'add+  | Operation'delete+  | Operation'replace+  deriving (Generic,Bounded,Enum,Show,Eq)++instance NFData Operation where+  rnf = rwhnf++instance ASN1 Operation where+  asn1decode = dec'BoundedEnum+  asn1encode = enc'BoundedEnum+++{- | Modify Response  (<https://tools.ietf.org/html/rfc4511#section-4.6 RFC4511 Section 4.6>)++> ModifyResponse ::= [APPLICATION 7] LDAPResult++-}+type ModifyResponse = ('APPLICATION 7 `IMPLICIT` LDAPResult)++{- | Add Operation  (<https://tools.ietf.org/html/rfc4511#section-4.7 RFC4511 Section 4.7>)++> AddRequest ::= [APPLICATION 8] SEQUENCE {+>      entry           LDAPDN,+>      attributes      AttributeList }++-}+data AddRequest = AddRequest+  { _AddRequest'entry      :: LDAPDN+  , _AddRequest'attributes :: AttributeList+  } deriving (Generic,Show,Eq)++instance NFData AddRequest++instance ASN1 AddRequest where+  asn1defTag _ = Application 8+  asn1decodeCompOf = AddRequest <$> asn1decode <*> asn1decode+  asn1encodeCompOf (AddRequest v1 v2) = asn1encodeCompOf (v1,v2)++{- | Attribute List++> AttributeList ::= SEQUENCE OF attribute Attribute++-}+type AttributeList = [Attribute]++{- | Add Response  (<https://tools.ietf.org/html/rfc4511#section-4.7 RFC4511 Section 4.7>)++> AddResponse ::= [APPLICATION 9] LDAPResult++-}+type AddResponse = ('APPLICATION 9 `IMPLICIT` LDAPResult)+++{- | Delete Operation  (<https://tools.ietf.org/html/rfc4511#section-4.8 RFC4511 Section 4.8>)++> DelRequest ::= [APPLICATION 10] LDAPDN++-}+type DelRequest = ('APPLICATION 10 `IMPLICIT` LDAPDN)++{- | Delete Response  (<https://tools.ietf.org/html/rfc4511#section-4.8 RFC4511 Section 4.8>)++> DelResponse ::= [APPLICATION 11] LDAPResult++-}+type DelResponse = ('APPLICATION 11 `IMPLICIT` LDAPResult)++{- | Modify DN Operation  (<https://tools.ietf.org/html/rfc4511#section-4.9 RFC4511 Section 4.9>)++ModifyDNRequest ::= [APPLICATION 12] SEQUENCE {+     entry           LDAPDN,+     newrdn          RelativeLDAPDN,+     deleteoldrdn    BOOLEAN,+     newSuperior     [0] LDAPDN OPTIONAL }++-}+data ModifyDNRequest = ModifyDNRequest+  { _ModifyDNRequest'entry        :: LDAPDN+  , _ModifyDNRequest'newrdn       :: RelativeLDAPDN+  , _ModifyDNRequest'deleteoldrdn :: Bool+  , _ModifyDNRequest'newSuperior  :: Maybe ('CONTEXTUAL 0 `IMPLICIT` LDAPDN)+  } deriving (Generic,Show,Eq)++instance NFData ModifyDNRequest++instance ASN1 ModifyDNRequest where+  asn1defTag _ = Application 12+  asn1decodeCompOf = ModifyDNRequest <$> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode+  asn1encodeCompOf (ModifyDNRequest v1 v2 v3 v4) = asn1encodeCompOf (v1,v2,v3,v4)+++{- | Modify DN Response  (<https://tools.ietf.org/html/rfc4511#section-4.9 RFC4511 Section 4.9>)++> ModifyDNResponse ::= [APPLICATION 13] LDAPResult++-}+type ModifyDNResponse = ('APPLICATION 13 `IMPLICIT` LDAPResult)+++{- | Compare Operation  (<https://tools.ietf.org/html/rfc4511#section-4.10 RFC4511 Section 4.10>)++> CompareRequest ::= [APPLICATION 14] SEQUENCE {+>      entry           LDAPDN,+>      ava             AttributeValueAssertion }++-}+data CompareRequest = CompareRequest+  { _CompareRequest'entry :: LDAPDN+  , _CompareRequest'ava   :: AttributeValueAssertion+  } deriving (Generic,Show,Eq)++instance NFData CompareRequest++instance ASN1 CompareRequest where+  asn1defTag _ = Application 14+  asn1decodeCompOf = CompareRequest <$> asn1decode <*> asn1decode+  asn1encodeCompOf (CompareRequest v1 v2) = asn1encodeCompOf (v1,v2)++{- | Compare Response  (<https://tools.ietf.org/html/rfc4511#section-4.10 RFC4511 Section 4.10>)++> CompareResponse ::= [APPLICATION 15] LDAPResult++-}+type CompareResponse = ('APPLICATION 15 `IMPLICIT` LDAPResult)+++{- | Abandon Operation  (<https://tools.ietf.org/html/rfc4511#section-4.11 RFC4511 Section 4.11>)++> AbandonRequest ::= [APPLICATION 16] MessageID++-}+type AbandonRequest = ('APPLICATION 16 `IMPLICIT` MessageID)++{- | Extended Request  (<https://tools.ietf.org/html/rfc4511#section-4.12 RFC4511 Section 4.12>)++> ExtendedRequest ::= [APPLICATION 23] SEQUENCE {+>      requestName      [0] LDAPOID,+>      requestValue     [1] OCTET STRING OPTIONAL }++-}+data ExtendedRequest = ExtendedRequest+  { _ExtendedRequest'responseName  ::       ('CONTEXTUAL 0 `IMPLICIT` LDAPOID)+  , _ExtendedRequest'responseValue :: Maybe ('CONTEXTUAL 1 `IMPLICIT` OCTET_STRING)+  } deriving (Generic,Show,Eq)++instance NFData ExtendedRequest++instance ASN1 ExtendedRequest where+  asn1defTag _ = Application 23+  asn1decodeCompOf = ExtendedRequest <$> asn1decode <*> asn1decode+  asn1encodeCompOf (ExtendedRequest v1 v2) = asn1encodeCompOf (v1,v2)++{- | Extended Response  (<https://tools.ietf.org/html/rfc4511#section-4.12 RFC4511 Section 4.12>)++> ExtendedResponse ::= [APPLICATION 24] SEQUENCE {+>      COMPONENTS OF LDAPResult,+>      responseName     [10] LDAPOID OPTIONAL,+>      responseValue    [11] OCTET STRING OPTIONAL }++-}+data ExtendedResponse = ExtendedResponse+  { _ExtendedResponse'LDAPResult    :: LDAPResult+  , _ExtendedResponse'responseName  :: Maybe ('CONTEXTUAL 10 `IMPLICIT` LDAPOID)+  , _ExtendedResponse'responseValue :: Maybe ('CONTEXTUAL 11 `IMPLICIT` OCTET_STRING)+  } deriving (Generic,Show,Eq)++instance NFData ExtendedResponse++instance ASN1 ExtendedResponse where+  asn1defTag _ = Application 24+  asn1decodeCompOf = do+    _ExtendedResponse'LDAPResult    <- asn1decodeCompOf+    _ExtendedResponse'responseName  <- asn1decode+    _ExtendedResponse'responseValue <- asn1decode+    pure ExtendedResponse{..}++  asn1encodeCompOf (ExtendedResponse{..})+    = enc'SEQUENCE_COMPS [ asn1encodeCompOf _ExtendedResponse'LDAPResult+                         , asn1encode       _ExtendedResponse'responseName+                         , asn1encode       _ExtendedResponse'responseValue+                         ]+++{- | Intermediate Response  (<https://tools.ietf.org/html/rfc4511#section-4.13 RFC4511 Section 4.13>)++> IntermediateResponse ::= [APPLICATION 25] SEQUENCE {+>         responseName     [0] LDAPOID OPTIONAL,+>         responseValue    [1] OCTET STRING OPTIONAL }++-}+data IntermediateResponse = IntermediateResponse+  { _IntermediateResponse'responseName  :: Maybe ('CONTEXTUAL 0 `IMPLICIT` LDAPOID)+  , _IntermediateResponse'responseValue :: Maybe ('CONTEXTUAL 1 `IMPLICIT` OCTET_STRING)+  } deriving (Generic,Show,Eq)++instance NFData IntermediateResponse++instance ASN1 IntermediateResponse where+  asn1defTag _ = Application 25+  asn1decodeCompOf = IntermediateResponse <$> asn1decode <*> asn1decode+  asn1encodeCompOf (IntermediateResponse v1 v2) = asn1encodeCompOf (v1,v2)

@@ -0,0 +1,140 @@+-- 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 DeriveGeneric #-}++module LDAPv3.ResultCode (ResultCode(..)) where++import           Common+import           Data.ASN1+import qualified Data.Map.Strict as Map+import           Data.Tuple      (swap)++fromEnumeratedMap :: Map.Map ResultCode Int64+fromEnumeratedMap = Map.fromAscList mapping++toEnumeratedMap :: Map.Map Int64 ResultCode+toEnumeratedMap = Map.fromAscList (swap <$> mapping)++mapping :: [(ResultCode,Int64)]+mapping = [ (ResultCode'success                      , 0)+          , (ResultCode'operationsError              , 1)+          , (ResultCode'protocolError                , 2)+          , (ResultCode'timeLimitExceeded            , 3)+          , (ResultCode'sizeLimitExceeded            , 4)+          , (ResultCode'compareFalse                 , 5)+          , (ResultCode'compareTrue                  , 6)+          , (ResultCode'authMethodNotSupported       , 7)+          , (ResultCode'strongerAuthRequired         , 8)+             -- 9 reserved --+          , (ResultCode'referral                     ,10)+          , (ResultCode'adminLimitExceeded           ,11)+          , (ResultCode'unavailableCriticalExtension ,12)+          , (ResultCode'confidentialityRequired      ,13)+          , (ResultCode'saslBindInProgress           ,14)+          , (ResultCode'noSuchAttribute              ,16)+          , (ResultCode'undefinedAttributeType       ,17)+          , (ResultCode'inappropriateMatching        ,18)+          , (ResultCode'constraintViolation          ,19)+          , (ResultCode'attributeOrValueExists       ,20)+          , (ResultCode'invalidAttributeSyntax       ,21)+             -- 22-31 unused --+          , (ResultCode'noSuchObject                 ,32)+          , (ResultCode'aliasProblem                 ,33)+          , (ResultCode'invalidDNSyntax              ,34)+             -- 35 reserved for undefined isLeaf --+          , (ResultCode'aliasDereferencingProblem    ,36)+             -- 37-47 unused --+          , (ResultCode'inappropriateAuthentication  ,48)+          , (ResultCode'invalidCredentials           ,49)+          , (ResultCode'insufficientAccessRights     ,50)+          , (ResultCode'busy                         ,51)+          , (ResultCode'unavailable                  ,52)+          , (ResultCode'unwillingToPerform           ,53)+          , (ResultCode'loopDetect                   ,54)+             -- 55-63 unused --+          , (ResultCode'namingViolation              ,64)+          , (ResultCode'objectClassViolation         ,65)+          , (ResultCode'notAllowedOnNonLeaf          ,66)+          , (ResultCode'notAllowedOnRDN              ,67)+          , (ResultCode'entryAlreadyExists           ,68)+          , (ResultCode'objectClassModsProhibited    ,69)+             -- 70 reserved for CLDAP --+          , (ResultCode'affectsMultipleDSAs          ,71)+             -- 72-79 unused --+          , (ResultCode'other                        ,80)+          ]++-- | 'LDAPv3.LDAPResult' Result Code+data ResultCode+    = ResultCode'success+    | ResultCode'operationsError+    | ResultCode'protocolError+    | ResultCode'timeLimitExceeded+    | ResultCode'sizeLimitExceeded+    | ResultCode'compareFalse+    | ResultCode'compareTrue+    | ResultCode'authMethodNotSupported+    | ResultCode'strongerAuthRequired+      -- 9 reserved --+    | ResultCode'referral+    | ResultCode'adminLimitExceeded+    | ResultCode'unavailableCriticalExtension+    | ResultCode'confidentialityRequired+    | ResultCode'saslBindInProgress+    | ResultCode'noSuchAttribute+    | ResultCode'undefinedAttributeType+    | ResultCode'inappropriateMatching+    | ResultCode'constraintViolation+    | ResultCode'attributeOrValueExists+    | ResultCode'invalidAttributeSyntax+      -- 22-31 unused --+    | ResultCode'noSuchObject+    | ResultCode'aliasProblem+    | ResultCode'invalidDNSyntax+      -- 35 reserved for undefined isLeaf --+    | ResultCode'aliasDereferencingProblem+      -- 37-47 unused --+    | ResultCode'inappropriateAuthentication+    | ResultCode'invalidCredentials+    | ResultCode'insufficientAccessRights+    | ResultCode'busy+    | ResultCode'unavailable+    | ResultCode'unwillingToPerform+    | ResultCode'loopDetect+      -- 55-63 unused --+    | ResultCode'namingViolation+    | ResultCode'objectClassViolation+    | ResultCode'notAllowedOnNonLeaf+    | ResultCode'notAllowedOnRDN+    | ResultCode'entryAlreadyExists+    | ResultCode'objectClassModsProhibited+      -- 70 reserved for CLDAP --+    | ResultCode'affectsMultipleDSAs+      -- 72-79 unused --+    | ResultCode'other+    deriving (Generic,Show,Eq,Ord,Bounded,Enum)++instance NFData ResultCode where+  rnf = rwhnf++instance ASN1 ResultCode where+  asn1decode = (\(ENUMERATED x) -> x) <$> asn1decode+  asn1encode = asn1encode . ENUMERATED++instance Enumerated ResultCode where+  toEnumerated   = Map.lookup `flip` toEnumeratedMap+  fromEnumerated = Map.findWithDefault undefined `flip` fromEnumeratedMap

@@ -0,0 +1,234 @@+-- 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 #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Arbitrary () where++import           LDAPv3++import           Data.Coerce               (coerce)+import           Data.Int+import qualified Data.Text.Short           as TS+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_FALSE where+  arbitrary = pure BOOL_TRUE++instance Arbitrary Control where+  arbitrary = Control <$> arbitrary <*> oneof [pure Nothing, pure (Just BOOL_TRUE)] <*> 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 <*> arbitrary+  shrink = genericShrink++instance Arbitrary MatchingRuleAssertion where+  arbitrary = MatchingRuleAssertion <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+  shrink = genericShrink++instance Arbitrary Substring where+  arbitrary = oneof [ Substring'initial <$> arbitrary+                    , Substring'any <$> arbitrary+                    , Substring'final <$> arbitrary+                    ]+  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

@@ -0,0 +1,455 @@+-- 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 OverloadedLists     #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main (main) where++import           LDAPv3++import qualified Codec.Base16          as B16+import           Data.Binary           as Bin+import qualified Data.ByteString.Lazy  as BSL+import           Data.Char             (isSpace)+import           Data.Either+import           Data.List.NonEmpty    (NonEmpty (..))+import qualified Data.Text.Short       as TS++import           Test.Tasty+import           Test.Tasty.HUnit+import           Test.Tasty.QuickCheck as QC++import           Arbitrary             ()++main :: IO ()+main = defaultMain tests++tests, qcProps, unitTests :: TestTree+tests = testGroup "Tests" [unitTests, qcProps]++----------------------------------------------------------------------------++qcProps = testGroup "Properties"+  [ QC.testProperty "MessageID round-trip" $+      \msgid -> let msg = LDAPMessage msgid+                                      (ProtocolOp'bindRequest (BindRequest 3 "" (AuthenticationChoice'simple "")))+                                      Nothing+                in decode (encode msg) == msg++  , QC.testProperty "decode . encode == id @LDAPMessage" $+      \(msg :: LDAPMessage) -> (decode . encode) msg === msg++  , QC.testProperty "decode multiple" $+      \msg1 msg2 -> decodeMulti (encode msg1 `mappend` encode msg2) === ([msg1,msg2],mempty)++  , QC.testProperty "decode with noise" $+      \msg1 noise -> decodeOne (encode msg1 `mappend` noise) === Right (msg1,noise)++  , QC.testProperty "decode garbage" $ -- this has a very low probability of the random noise being a valid LDAPMessage+      \noise -> isLeft (decodeOne noise)++  ]++decodeOne :: BSL.ByteString -> Either BSL.ByteString (LDAPMessage,BSL.ByteString)+decodeOne raw = case decodeOrFail raw of+  Left (rest,_,_)  -> Left rest+  Right (rest,_,v) -> Right (v,rest)++decodeMulti :: BSL.ByteString -> ([LDAPMessage],BSL.ByteString)+decodeMulti = go []+  where+    go acc raw+      | BSL.null raw = (reverse acc, raw)+      | otherwise = case decodeOne raw of+          Left rest      -> (reverse acc, rest)+          Right (v,rest) -> go (v:acc) rest++----------------------------------------------------------------------------++-- local helper+hex :: TS.ShortText -> BSL.ByteString+hex = either error id . B16.decode . TS.toShortByteString . TS.filter (not . isSpace)++unitTests = testGroup "Reference samples"+  [ testGroup tlabel+    [ testCase "encode" $ Bin.encode ref_msg @?= ref_bin+    , testCase "decode" $ Bin.decode ref_bin @?= ref_msg+    ]++  | (tlabel,ref_bin,ref_msg) <-++    [ ( "bindRequest #1"+      , hex"30 0c 02 01 01 60 07 02 01 03 04 00 80 00"+      , LDAPMessage { _LDAPMessage'messageID = MessageID 1+                    , _LDAPMessage'protocolOp = ProtocolOp'bindRequest+                        ( BindRequest+                            { bindRequest'version = 3+                            , bindRequest'name = ""+                            , bindRequest'authentication = AuthenticationChoice'simple ""+                            }+                        )+                    , _LDAPMessage'controls = Nothing+                    }+      )++    , ( "bindRequest #2"+      , hex"30 2b 02 01 01 60 26 02 01 03 04 1a 63 6e 3d 61 64 6d 69 6e 2c 64 63 3d 65 78 61 6d 70 6c 65 2c 64 63 3d 6f 72 67 80 05 61 64 6d 69 6e"+      , LDAPMessage { _LDAPMessage'messageID = MessageID 1+                    , _LDAPMessage'protocolOp = ProtocolOp'bindRequest+                        ( BindRequest+                            { bindRequest'version = 3+                            , bindRequest'name = "cn=admin,dc=example,dc=org"+                            , bindRequest'authentication = AuthenticationChoice'simple "admin"+                            }+                        )+                    , _LDAPMessage'controls = Nothing+                    }+      )++    , ( "bindRequest #3"+      , hex"30 18 02 01 02 60 13 02 01 03 04 00 a3 0c 04 0a 44 49 47 45 53 54 2d 4d 44 35"+      , LDAPMessage { _LDAPMessage'messageID = MessageID 2+                    , _LDAPMessage'protocolOp = ProtocolOp'bindRequest+                        ( BindRequest+                            { bindRequest'version = 3+                            , bindRequest'name = ""+                            , bindRequest'authentication = AuthenticationChoice'sasl+                                ( IMPLICIT+                                    ( SaslCredentials+                                        { _SaslCredentials'mechanism = "DIGEST-MD5"+                                        , _SaslCredentials'credentials = Nothing+                                        }+                                    )+                                )+                            }+                        )+                    , _LDAPMessage'controls = Nothing+                    }+      )++    , ( "bindResponse #1"+      , hex"30 0c 02 01 01 61 07 0a 01 00 04 00 04 00"+      , LDAPMessage { _LDAPMessage'messageID = MessageID 1+                    , _LDAPMessage'protocolOp = ProtocolOp'bindResponse+                        ( BindResponse+                            { _BindResponse'LDAPResult = LDAPResult+                                { _LDAPResult'resultCode = ResultCode'success+                                , _LDAPResult'matchedDN = ""+                                , _LDAPResult'diagnosticMessage = ""+                                , _LDAPResult'referral = Nothing+                                }+                            , _BindResponse'serverSaslCreds = Nothing+                            }+                        )+                    , _LDAPMessage'controls = Nothing+                    }+      )++    , ( "bindResponse #2"+      , hex"30 41 02 01 01 61 3c 0a 01 35 04 00 04 35 75 6e 61 75 74 68 65 6e 74 69 63 61 74 65 64 20 62 69 6e 64 20 28 44 4e 20 77 69 74 68 20 6e 6f 20 70 61 73 73 77 6f 72 64 29 20 64 69 73 61 6c 6c 6f 77 65 64"+      , LDAPMessage { _LDAPMessage'messageID = MessageID 1+                    , _LDAPMessage'protocolOp = ProtocolOp'bindResponse+                        ( BindResponse+                            { _BindResponse'LDAPResult = LDAPResult+                                { _LDAPResult'resultCode = ResultCode'unwillingToPerform+                                , _LDAPResult'matchedDN = ""+                                , _LDAPResult'diagnosticMessage = "unauthenticated bind (DN with no password) disallowed"+                                , _LDAPResult'referral = Nothing+                                }+                            , _BindResponse'serverSaslCreds = Nothing+                            }+                        )+                    , _LDAPMessage'controls = Nothing+                    }+      )++    , ( "bindResponse #3"+      , hex"30 0c 02 01 01 61 07 0a 01 31 04 00 04 00"+      , LDAPMessage { _LDAPMessage'messageID = MessageID 1+                    , _LDAPMessage'protocolOp = ProtocolOp'bindResponse+                        ( BindResponse+                            { _BindResponse'LDAPResult = LDAPResult+                                { _LDAPResult'resultCode = ResultCode'invalidCredentials+                                , _LDAPResult'matchedDN = ""+                                , _LDAPResult'diagnosticMessage = ""+                                , _LDAPResult'referral = Nothing+                                }+                            , _BindResponse'serverSaslCreds = Nothing+                            }+                        )+                    , _LDAPMessage'controls = Nothing+                    }+      )+++    , ( "searchRequest #1"+      , hex"30 36 02 01 02 63 31 04 11 64 63 3d 65 78 61 6d 70 6c 65 2c 64 63 3d 6f 72 67 0a 01 02 0a 01 00 02 01 00 02 01 00 01 01 00 87 0b 6f 62 6a 65 63 74 63 6c 61 73 73 30 00"++      , LDAPMessage { _LDAPMessage'messageID = MessageID 2+                    , _LDAPMessage'protocolOp = ProtocolOp'searchRequest+                        ( SearchRequest+                            { _SearchRequest'baseObject = "dc=example,dc=org"+                            , _SearchRequest'scope = Scope'wholeSubtree+                            , _SearchRequest'derefAliases = DerefAliases'neverDerefAliases+                            , _SearchRequest'sizeLimit = 0+                            , _SearchRequest'timeLimit = 0+                            , _SearchRequest'typesOnly = False+                            , _SearchRequest'filter = Filter'present ( IMPLICIT "objectclass" )+                            , _SearchRequest'attributes = []+                            }+                        )+                    , _LDAPMessage'controls = Nothing+                    }+      )++    , ( "searchRequest #2"+      , hex"30 42 02 01 02 63 3d 04 11 64 63 3d 65 78 61 6d 70 6c 65 2c 64 63 3d 6f 72 67 0a 01 02 0a 01 00 02 01 00 02 01 00 01 01 00 a2 17 a3 15 04 0b 6f 62 6a 65 63 74 43 6c 61 73 73 04 06 70 65 72 73 6f 6e 30 00"++      , LDAPMessage { _LDAPMessage'messageID = MessageID 2+                    , _LDAPMessage'protocolOp = ProtocolOp'searchRequest+                        ( SearchRequest+                            { _SearchRequest'baseObject = "dc=example,dc=org"+                            , _SearchRequest'scope = Scope'wholeSubtree+                            , _SearchRequest'derefAliases = DerefAliases'neverDerefAliases+                            , _SearchRequest'sizeLimit = 0+                            , _SearchRequest'timeLimit = 0+                            , _SearchRequest'typesOnly = False+                            , _SearchRequest'filter = Filter'not+                                ( EXPLICIT+                                    ( Filter'equalityMatch+                                        ( IMPLICIT+                                            ( AttributeValueAssertion+                                                { _AttributeValueAssertion'attributeDesc = "objectClass"+                                                , _AttributeValueAssertion'assertionValue = "person"+                                                }+                                            )+                                        )+                                    )+                                )+                            , _SearchRequest'attributes = []+                            }+                        )+                    , _LDAPMessage'controls = Nothing+                    }+      )++    , ( "searchRequest #3"+      , hex"30 81 80 02 01 02 63 7b 04 11 64 63 3d 65 78 61 6d 70 6c 65 2c 64 63 3d 6f 72 67 0a 01 02 0a 01 00 02 01 00 02 01 00 01 01 00 a0 55 a2 3c a1 3a a9 1f 82 02 6f 75 83 16 52 65 73 65 61 72 63 68 41 6e 64 44 65 76 65 6c 6f 70 6d 65 6e 74 84 01 ff a9 17 82 02 6f 75 83 0e 48 75 6d 61 6e 52 65 73 6f 75 72 63 65 73 84 01 ff a3 15 04 0b 6f 62 6a 65 63 74 43 6c 61 73 73 04 06 70 65 72 73 6f 6e 30 00"++      , LDAPMessage { _LDAPMessage'messageID = MessageID 2+                    , _LDAPMessage'protocolOp = ProtocolOp'searchRequest+                        ( SearchRequest+                            { _SearchRequest'baseObject = "dc=example,dc=org"+                            , _SearchRequest'scope = Scope'wholeSubtree+                            , _SearchRequest'derefAliases = DerefAliases'neverDerefAliases+                            , _SearchRequest'sizeLimit = 0+                            , _SearchRequest'timeLimit = 0+                            , _SearchRequest'typesOnly = False+                            , _SearchRequest'filter = Filter'and+                                ( IMPLICIT+                                    ( SET1+                                        ( Filter'not+                                            ( EXPLICIT+                                                ( Filter'or+                                                    ( IMPLICIT+                                                        ( SET1+                                                            ( Filter'extensibleMatch+                                                                ( IMPLICIT+                                                                    ( MatchingRuleAssertion+                                                                        { _MatchingRuleAssertion'matchingRule = Nothing+                                                                        , _MatchingRuleAssertion'type = Just ( IMPLICIT "ou" )+                                                                        , _MatchingRuleAssertion'matchValue = IMPLICIT "ResearchAndDevelopment"+                                                                        , _MatchingRuleAssertion'dnAttributes = Just ( IMPLICIT BOOL_TRUE )+                                                                        }+                                                                    )+                                                                ) :|+                                                                [ Filter'extensibleMatch+                                                                    ( IMPLICIT+                                                                        ( MatchingRuleAssertion+                                                                            { _MatchingRuleAssertion'matchingRule = Nothing+                                                                            , _MatchingRuleAssertion'type = Just ( IMPLICIT "ou" )+                                                                            , _MatchingRuleAssertion'matchValue = IMPLICIT "HumanResources"+                                                                            , _MatchingRuleAssertion'dnAttributes = Just ( IMPLICIT BOOL_TRUE )+                                                                            }+                                                                        )+                                                                    )+                                                                ]+                                                            )+                                                        )+                                                    )+                                                )+                                            ) :|+                                            [ Filter'equalityMatch+                                                ( IMPLICIT+                                                    ( AttributeValueAssertion+                                                        { _AttributeValueAssertion'attributeDesc = "objectClass"+                                                        , _AttributeValueAssertion'assertionValue = "person"+                                                        }+                                                    )+                                                )+                                            ]+                                        )+                                    )+                                )+                            , _SearchRequest'attributes = []+                            }+                        )+                    , _LDAPMessage'controls = Nothing+                    }+++      )++    , ( "searchRequest #4"+      , hex"30 3a 02 01 02 63 35 04 11 64 63 3d 65 78 61 6d 70 6c 65 2c 64 63 3d 6f 72 67 0a 01 02 0a 01 00 02 01 00 02 01 00 01 01 00 a4 0f 04 02 63 6e 30 09 80 01 61 81 01 6d 82 01 6e 30 00"+      , LDAPMessage { _LDAPMessage'messageID = MessageID 2+                    , _LDAPMessage'protocolOp = ProtocolOp'searchRequest+                        ( SearchRequest+                            { _SearchRequest'baseObject = "dc=example,dc=org"+                            , _SearchRequest'scope = Scope'wholeSubtree+                            , _SearchRequest'derefAliases = DerefAliases'neverDerefAliases+                            , _SearchRequest'sizeLimit = 0+                            , _SearchRequest'timeLimit = 0+                            , _SearchRequest'typesOnly = False+                            , _SearchRequest'filter = Filter'substrings+                                ( IMPLICIT+                                    ( SubstringFilter+                                        { _SubstringFilter'type = "cn"+                                        , _SubstringFilter'substrings =+                                            [ Substring'initial "a"+                                            , Substring'any "m"+                                            , Substring'final "n"+                                            ]+                                        }+                                    )+                                )+                            , _SearchRequest'attributes = []+                            }+                        )+                    , _LDAPMessage'controls = Nothing+                    }+      )++    , ( "searchResEntry #1"+      , hex"30 6e 02 01 02 64 69 04 11 64 63 3d 65 78 61 6d 70 6c 65 2c 64 63 3d 6f 72 67 30 54 30 2c 04 0b 6f 62 6a 65 63 74 43 6c 61 73 73 31 1d 04 03 74 6f 70 04 08 64 63 4f 62 6a 65 63 74 04 0c 6f 72 67 61 6e 69 7a 61 74 69 6f 6e 30 13 04 01 6f 31 0e 04 0c 45 78 61 6d 70 6c 65 20 49 6e 63 2e 30 0f 04 02 64 63 31 09 04 07 65 78 61 6d 70 6c 65"+      , LDAPMessage { _LDAPMessage'messageID = MessageID 2+                    , _LDAPMessage'protocolOp = ProtocolOp'searchResEntry+                        ( SearchResultEntry+                            { _SearchResultEntry'objectName = "dc=example,dc=org"+                            , _SearchResultEntry'attributes =+                                [ PartialAttribute+                                    { _PartialAttribute'type = "objectClass"+                                    , _PartialAttribute'vals = SET+                                        [ "top"+                                        , "dcObject"+                                        , "organization"+                                        ]+                                    }+                                , PartialAttribute+                                    { _PartialAttribute'type = "o"+                                    , _PartialAttribute'vals = SET [ "Example Inc." ]+                                    }+                                , PartialAttribute+                                    { _PartialAttribute'type = "dc"+                                    , _PartialAttribute'vals = SET [ "example" ]+                                    }+                                ]+                            }+                        )+                    , _LDAPMessage'controls = Nothing+                    }+      )++    , ( "searchResEntry #2"+      , hex"30 81 ce 02 01 02 64 81 c8 04 1a 63 6e 3d 61 64 6d 69 6e 2c 64 63 3d 65 78 61 6d 70 6c 65 2c 64 63 3d 6f 72 67 30 81 a9 30 39 04 0b 6f 62 6a 65 63 74 43 6c 61 73 73 31 2a 04 14 73 69 6d 70 6c 65 53 65 63 75 72 69 74 79 4f 62 6a 65 63 74 04 12 6f 72 67 61 6e 69 7a 61 74 69 6f 6e 61 6c 52 6f 6c 65 30 0d 04 02 63 6e 31 07 04 05 61 64 6d 69 6e 30 23 04 0b 64 65 73 63 72 69 70 74 69 6f 6e 31 14 04 12 4c 44 41 50 20 61 64 6d 69 6e 69 73 74 72 61 74 6f 72 30 38 04 0c 75 73 65 72 50 61 73 73 77 6f 72 64 31 28 04 26 7b 53 53 48 41 7d 54 66 50 53 6f 37 46 68 58 38 63 34 53 6b 6c 4f 52 58 75 46 54 55 75 67 39 38 64 4e 46 4c 6b 34"+      , LDAPMessage { _LDAPMessage'messageID = MessageID 2+                    , _LDAPMessage'protocolOp = ProtocolOp'searchResEntry+                        ( SearchResultEntry+                            { _SearchResultEntry'objectName = "cn=admin,dc=example,dc=org"+                            , _SearchResultEntry'attributes =+                                [ PartialAttribute+                                    { _PartialAttribute'type = "objectClass"+                                    , _PartialAttribute'vals = SET+                                        [ "simpleSecurityObject"+                                        , "organizationalRole"+                                        ]+                                    }+                                , PartialAttribute+                                    { _PartialAttribute'type = "cn"+                                    , _PartialAttribute'vals = SET [ "admin" ]+                                    }+                                , PartialAttribute+                                    { _PartialAttribute'type = "description"+                                    , _PartialAttribute'vals = SET [ "LDAP administrator" ]+                                    }+                                , PartialAttribute+                                    { _PartialAttribute'type = "userPassword"+                                    , _PartialAttribute'vals = SET [ "{SSHA}TfPSo7FhX8c4SklORXuFTUug98dNFLk4" ]+                                    }+                                ]+                            }+                        )+                    , _LDAPMessage'controls = Nothing+                    }+      )++    , ( "searchResDone #1"+      , hex"30 0c 02 01 02 65 07 0a 01 00 04 00 04 00"+      , LDAPMessage { _LDAPMessage'messageID = MessageID 2+                    , _LDAPMessage'protocolOp = ProtocolOp'searchResDone+                        ( IMPLICIT+                            ( LDAPResult+                                { _LDAPResult'resultCode = ResultCode'success+                                , _LDAPResult'matchedDN = ""+                                , _LDAPResult'diagnosticMessage = ""+                                , _LDAPResult'referral = Nothing+                                }+                            )+                        )+                    , _LDAPMessage'controls = Nothing+                    }+      )++    , ( "searchResDone #2"+      , hex"30 0c 02 01 02 65 07 0a 01 20 04 00 04 00"+      , LDAPMessage { _LDAPMessage'messageID = MessageID 2+                    , _LDAPMessage'protocolOp = ProtocolOp'searchResDone+                        ( IMPLICIT+                            ( LDAPResult+                                { _LDAPResult'resultCode = ResultCode'noSuchObject+                                , _LDAPResult'matchedDN = ""+                                , _LDAPResult'diagnosticMessage = ""+                                , _LDAPResult'referral = Nothing+                                }+                            )+                        )+                    , _LDAPMessage'controls = Nothing+                    }+      )++    , ( "unbindRequest"+      , hex"30 05 02 01 03 42 00"+      , LDAPMessage { _LDAPMessage'messageID = MessageID 3+                    , _LDAPMessage'protocolOp = ProtocolOp'unbindRequest (IMPLICIT ())+                    , _LDAPMessage'controls = Nothing+                    }+      )++    ]++  ]