diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,11 @@ +See also http://pvp.haskell.org/faq + +## 0.1.0.0 + +Major API restructuring getting rid of `newtype` annotation wrappers in exposed API. + +--- + +## 0.0.0.0 + +First version. Released on an unsuspecting world. diff --git a/LDAPv3.cabal b/LDAPv3.cabal --- a/LDAPv3.cabal +++ b/LDAPv3.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: LDAPv3 -version: 0.0.0.0 +version: 0.1.0.0 synopsis: Lightweight Directory Access Protocol (LDAP) version 3 license: GPL-2.0-or-later @@ -10,11 +10,16 @@ maintainer: hvr@gnu.org bug-reports: https://github.com/hvr/LDAPv3/issues category: Network +tested-with: GHC==8.8.1, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3 description: - This library provides a pure Haskell implementation of the /Lightweight Directory Access Protocol (LDAP)/ version 3 as specified in . + This library provides a pure Haskell implementation of the /Lightweight Directory Access Protocol (LDAP)/ version 3 as specified in (see "LDAPv3.Message"). . Serializing and deserializing to and from the wire encoding for the purpose of implementing network clients and servers is supported via 'Binary' instances (see ). + . + Moreover, this library also implements /String Representation of Search Filters/ as per (see "LDAPv3.StringRepr") +extra-source-files: ChangeLog.md + source-repository head type: git location: https://github.com/hvr/LDAPv3.git @@ -23,8 +28,10 @@ default-language: Haskell2010 other-extensions: BangPatterns + CPP ConstraintKinds DataKinds + DefaultSignatures DeriveFunctor DeriveGeneric FlexibleContexts @@ -33,8 +40,11 @@ KindSignatures LambdaCase MultiParamTypeClasses + OverloadedStrings RecordWildCards ScopedTypeVariables + StandaloneDeriving + Trustworthy TypeFamilies TypeOperators UndecidableInstances @@ -44,10 +54,12 @@ , binary ^>= 0.8.3 , bytestring ^>= 0.10.4 , text-short ^>= 0.1.3 + , text ^>= 1.2.3 , containers ^>= 0.5.5 || ^>= 0.6.0 , deepseq ^>= 1.4.0 , int-cast ^>= 0.2.0 , newtype ^>= 0.2.2 + , parsec ^>= 3.1.13 if !impl(ghc >= 8.0) build-depends: @@ -62,13 +74,18 @@ hs-source-dirs: src exposed-modules: - LDAPv3 + LDAPv3.Message + LDAPv3.StringRepr other-modules: Common Data.Int.Subtypes Data.ASN1 Data.ASN1.Prim + LDAPv3.AttributeDescription + LDAPv3.SearchFilter LDAPv3.ResultCode + LDAPv3.Message.Types + LDAPv3.Message.Annotated ------------------------------------------------------------------------------- diff --git a/src/Common.hs b/src/Common.hs --- a/src/Common.hs +++ b/src/Common.hs @@ -1,22 +1,28 @@ +{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} + 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 +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.Foldable as X (asum) +import Data.Functor.Identity as X +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 as X (Text) +import Data.Text.Short as X (ShortText) +import Data.Word as X +import GHC.Generics as X (Generic) +import GHC.TypeLits as X hiding (Text) +import Numeric.Natural as X (Natural) {-# INLINE rwhnf #-} rwhnf :: a -> () @@ -27,3 +33,6 @@ x `inside` (lb,ub) | lb > ub = error "inside: unsatifiable range" | otherwise = lb <= x && x <= ub + +impossible :: a +impossible = error "The impossible just happened!" diff --git a/src/Data/ASN1.hs b/src/Data/ASN1.hs --- a/src/Data/ASN1.hs +++ b/src/Data/ASN1.hs @@ -16,6 +16,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} @@ -27,36 +28,62 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Data.ASN1 ( ASN1(..) + , ASN1Constructed(..) + , ASN1Decode , ASN1Encode + , toBinaryPut + , toBinaryGet + + , asn1decodeParsec + + -- Generics support + + , GASN1EncodeCompOf, gasn1encodeCompOf + , GASN1DecodeCompOf, gasn1decodeCompOf + + , GASN1EncodeChoice, gasn1encodeChoice + , GASN1DecodeChoice, gasn1decodeChoice + + -- type-level combinators + , ENUMERATED(..), Enumerated(..) , IMPLICIT(..), implicit , EXPLICIT(..), explicit + , COMPONENTS_OF(..) + , CHOICE(..) , OCTET_STRING , NULL , BOOLEAN - , BOOLEAN_DEFAULT_FALSE(..) + , BOOLEAN_DEFAULT(..) , OPTIONAL , SET(..) , SET1(..) - , toBinaryPut - , toBinaryGet + -- term-level combinators + , asn1fail + , transformVia + , retag, wraptag - , with'SEQUENCE + , dec'SEQUENCE , enc'SEQUENCE , enc'SEQUENCE_COMPS - , with'CHOICE + , dec'SET_OF + , dec'SEQUENCE_OF + , dec'CHOICE + , dec'OPTIONAL + , dec'BoundedEnum , enc'BoundedEnum @@ -67,23 +94,38 @@ import Common import Data.ASN1.Prim import Data.Int.Subtypes +import GHC.Generics ((:*:) (..), (:+:) (..), K1 (..), M1 (..), Rep, V1, from, to) 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 qualified Data.Map.Strict as Map import Data.Set (Set) import qualified Data.Set as Set import Data.String (IsString) +import qualified Data.Text.Encoding as T import qualified Data.Text.Short as TS +import qualified Text.Parsec as P +import qualified Text.Parsec.Text as P ---------------------------------------------------------------------------- class Enumerated x where toEnumerated :: Int64 -> Maybe x + default toEnumerated :: (Bounded x, Enum x) => Int64 -> Maybe x + toEnumerated i0 + | Just i <- intCastMaybe i0 + , i `inside` (lb,ub) = Just (toEnum i) + | otherwise = Nothing + where + lb = fromEnum (minBound :: x) + ub = fromEnum (maxBound :: x) + fromEnumerated :: x -> Int64 + default fromEnumerated :: Enum x => x -> Int64 + fromEnumerated = intCast . fromEnum instance Enumerated Int64 where toEnumerated = Just @@ -91,15 +133,10 @@ instance Enumerated Int where toEnumerated = intCastMaybe - fromEnumerated = fromIntegral + fromEnumerated = intCast ---------------------------------------------------------------------------- -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 @@ -121,120 +158,203 @@ n1 <- x Nothing go xs (sz+n1) +instance Semigroup (ASN1Encode Word64) where + ASN1Encode x <> ASN1Encode y = ASN1Encode $ \case + Just _ -> error "ASN1Encode append called with tag-override" + Nothing -> (+) <$> x Nothing <*> y Nothing + 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) - } - - +---------------------------------------------------------------------------- +data ASN1Res x = Consumed ({- leftover -} Maybe TL) x + | Unexpected {- leftover -} TL + | UnexpectedEOF + deriving (Show,Functor) -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 - } +data Card = Card {- min -} !Word {- delta -} !Word + deriving (Eq,Ord,Show) +cardMaySkip :: Card -> Bool +cardMaySkip (Card 0 _) = True +cardMaySkip (Card _ _) = False -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 - } +-- addition +instance Semigroup Card where + Card l1 u1 <> Card l2 u2 = Card (l1+l2) (u1+u2) +instance Monoid Card where + mappend = (<>) + mempty = Card 0 0 -asn1decodeIsSingleton :: ASN1Decode x -> Maybe Tag -asn1decodeIsSingleton (ASN1Decode {..}) - | asn1dAny = Nothing - | [t1] <- Set.toList asn1dTags = Just t1 - | otherwise = Nothing +data ASN1Decode x = ASN1Decode + { asn1dTags :: !(Set Tag) -- + , asn1dAny :: !Bool -- declare which tags asn1dContent is possibly going to handle + , asn1dCard :: !Card -- lower&upper bounds of how many items asn1dCard is going to consume + , asn1dContent :: Maybe TL -> Get (ASN1Res x) -- 'Nothing' argument denotes EOF/EOC + } -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 +getASN1Decode :: ASN1Decode x -> Maybe TL -> Get (ASN1Res x) +getASN1Decode (ASN1Decode{..}) Nothing + | cardMaySkip asn1dCard = asn1dContent Nothing + | otherwise = pure UnexpectedEOF +getASN1Decode (ASN1Decode{..}) (Just tl@(t,_,_)) + | cardMaySkip asn1dCard || asn1dAny || Set.member t asn1dTags = asn1dContent (Just tl) + | otherwise = pure (Unexpected tl) --- | Left-biased "CHOICE" join (TODO: verify specific-match-first semantics are sane in presence of ANYs) -instance Semigroup (ASN1Decode x) where - x <> y +-- | "CHOICE" join +instance Alternative ASN1Decode where + empty = ASN1Decode mempty False mempty (pure . maybe UnexpectedEOF Unexpected) + x <|> y | asn1decodeIsEmpty x = y | asn1decodeIsEmpty y = x + | asn1dCard x /= asn1dCard y = error' "ASN1Decode: CHOICE over different cardinalities not supported" + | asn1dAny x, asn1dAny y = error' "ASN1Decode: CHOICE not possible over multiple ANYs" + | cardMaySkip (asn1dCard x) || cardMaySkip (asn1dCard y) = error' "ASN1Decode: CHOICE over OPTIONAL not supported" + | not (Set.null (asn1dTags x `Set.intersection` asn1dTags y)) = error' "ASN1Decode: CHOICEs overlap" | otherwise = ASN1Decode { asn1dTags = asn1dTags x <> asn1dTags y , asn1dAny = asn1dAny x || asn1dAny y + , asn1dCard = asn1dCard x , asn1dContent = \case - tl@(Just (t,_,_)) -> case () of + tl@(Just tl'@(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 + | otherwise -> pure (Unexpected tl') + Nothing -> pure UnexpectedEOF -- CHOICEs are allowed only among non-OPTIONALs } + where + error' s = error (s ++ " => " ++ show ((asn1dTags x, asn1dAny x, asn1dCard x), (asn1dTags y, asn1dAny y, asn1dCard y))) --- | Test whether 'mempty' + +asum'ASN1Decode :: [ASN1Decode x] -> ASN1Decode x +asum'ASN1Decode xs0 + | Map.size tagmap /= sum (map (Set.size . asn1dTags) xs) = error' "ASN1Decode: CHOICEs overlap" + | x0:_ <- xs = ASN1Decode { asn1dTags = mconcat (map asn1dTags xs) + , asn1dAny = any asn1dAny xs + , asn1dCard = asn1dCard x0 + , asn1dContent = \case + tl@(Just tl'@(t,_,_)) -> case () of + _ | Just h <- Map.lookup t tagmap -> h tl + | otherwise -> anydispatch tl' + Nothing -> pure UnexpectedEOF -- CHOICEs are allowed only among non-OPTIONALs + } + | otherwise = empty + where + xs = filter (not . asn1decodeIsEmpty) xs0 + + tagmap = mconcat [ Map.fromSet (const asn1dContent) asn1dTags | ASN1Decode{..} <- xs ] + + anydispatch = case [ asn1dContent | ASN1Decode{..} <- xs, asn1dAny ] of + [] -> \tl -> pure (Unexpected tl) + [x] -> x . Just + (_:_:_) -> error' "ASN1Decode: CHOICE not possible over multiple ANYs" + + error' :: String -> a + error' s = error (s ++ " => " ++ show [(asn1dTags x, asn1dAny x, asn1dCard x) | x <- xs ]) + + + +-- | Test whether it's a 'mempty' / 'empty' decoder asn1decodeIsEmpty :: ASN1Decode x -> Bool -asn1decodeIsEmpty ASN1Decode{..} = not asn1dAny && Set.null asn1dTags +asn1decodeIsEmpty ASN1Decode{..} = not asn1dAny && Set.null asn1dTags && asn1dCard == Card 0 0 -instance Monoid (ASN1Decode x) where - mempty = ASN1Decode mempty False (pure . maybe UnexpectedEOF Unexpected) - mappend = (<>) - -- TODO: optimized mconcat +-- | Test whether decoder ist /monomorphic/. In case of a monomorphic decoder, returns the single tag matched. +asn1decodeIsMono :: ASN1Decode x -> Maybe Tag +asn1decodeIsMono (ASN1Decode {..}) + | asn1dAny = Nothing + | [t1] <- Set.toList asn1dTags = Just t1 + | otherwise = Nothing +asn1DecodeSingleton :: Tag -> (TL -> Get x) -> ASN1Decode x +asn1DecodeSingleton t c = asn1DecodeSingleton' t ((Consumed Nothing <$>) . c) + +asn1DecodeSingleton' :: Tag -> (TL -> Get (ASN1Res x)) -> ASN1Decode x +asn1DecodeSingleton' t c = empty { asn1dTags = Set.singleton t + , asn1dCard = Card 1 0 + , asn1dContent = \case + Just tl@(t',_,_) | t /= t' -> pure (Unexpected tl) + | otherwise -> c tl + Nothing -> pure UnexpectedEOF + } + + +dec'OPTIONAL :: ASN1Decode x -> ASN1Decode (Maybe x) +dec'OPTIONAL x + | asn1dCard x /= Card 1 0 = error "OPTIONAL applied to non-singleton" + | otherwise = x { asn1dCard = Card 0 1 + , 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 + + 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 + pure x = empty { asn1dContent = \tl -> pure (Consumed tl x), asn1dAny = True } + (<*>) = ap'ASN1Decode + (*>) = then'ASN1Decode - 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") - } +ap'ASN1Decode :: ASN1Decode (a -> b) -> ASN1Decode a -> ASN1Decode b +ap'ASN1Decode f x + = ASN1Decode { asn1dAny = if fMaySkip then asn1dAny f || asn1dAny x else asn1dAny f + , asn1dTags = if fMaySkip then asn1dTags f <> asn1dTags x else asn1dTags f + , asn1dCard = asn1dCard f <> asn1dCard x + , asn1dContent = \mtl -> do + res <- getASN1Decode f mtl + case res of + Consumed (Just tl') f' -> do + a' <- getASN1Decode x (Just tl') + pure (fmap f' a') + Consumed Nothing f' -> do + mtl' <- getTagLength BER + a' <- getASN1Decode x mtl' + pure (fmap f' a') + Unexpected (t,_,_) -> + fail ("ap'ASN1Decode: Unexpected " ++ show t) + UnexpectedEOF -> + fail ("ap'ASN1Decode: UnexpectedEOF") + } + where + fMaySkip = cardMaySkip (asn1dCard f) --- instance MonadFail ASN1Decode where --- fail = asn1fail +then'ASN1Decode :: ASN1Decode a -> ASN1Decode b -> ASN1Decode b +then'ASN1Decode f x + = ASN1Decode { asn1dAny = if fMaySkip then asn1dAny f || asn1dAny x else asn1dAny f + , asn1dTags = if fMaySkip then asn1dTags f <> asn1dTags x else asn1dTags f + , asn1dCard = asn1dCard f <> asn1dCard x + , asn1dContent = \mtl -> do + res <- getASN1Decode f mtl + case res of + Consumed (Just tl') _ -> do + getASN1Decode x (Just tl') + Consumed Nothing _ -> do + mtl' <- getTagLength BER + getASN1Decode x mtl' + Unexpected (t,_,_) -> + fail ("then'ASN1Decode: Unexpected " ++ show t) + UnexpectedEOF -> + fail ("then'ASN1Decode: UnexpectedEOF") + } + where + fMaySkip = cardMaySkip (asn1dCard f) asn1fail :: String -> ASN1Decode a -asn1fail s = mempty { asn1dAny = True - , asn1dContent = \_ -> fail s - } +asn1fail s = empty { asn1dAny = True + , asn1dContent = \_ -> fail s + } toBinaryGet :: ASN1Decode x -> Get x toBinaryGet dec @@ -244,14 +364,6 @@ 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 @@ -267,25 +379,34 @@ UnexpectedEOF -> pure UnexpectedEOF } +asn1decodeParsec :: String -> P.Parser t -> ASN1Decode t +asn1decodeParsec l p = asn1decode `transformVia` f + where + f t = case P.parse (p <* P.eof) "" t of + Left _ -> Left ("invalid " ++ l) + Right v -> Right v + explicit :: Tag -> ASN1Decode x -> ASN1Decode x -explicit t body = with'Constructed (show t ++ " EXPLICIT") t body +explicit t body = dec'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" + | Just oldtag <- asn1decodeIsMono old + = empty { asn1dTags = Set.singleton newtag + , asn1dCard = asn1dCard old + , 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-monomorphic ASN1Decode" -with'CHOICE :: [ASN1Decode x] -> ASN1Decode x -with'CHOICE = mconcat +dec'CHOICE :: [ASN1Decode x] -> ASN1Decode x +dec'CHOICE [] = error "CHOICE over no choices" +dec'CHOICE xs = asum'ASN1Decode xs -with'Constructed :: forall x . String -> Tag -> ASN1Decode x -> ASN1Decode x -with'Constructed l tag body = asn1DecodeSingleton' tag go +dec'Constructed :: forall x . String -> Tag -> ASN1Decode x -> ASN1Decode x +dec'Constructed l tag body = asn1DecodeSingleton' tag go where go :: TL -> Get (ASN1Res x) go (_,Primitive,_) = fail (l ++ " with primitive encoding") @@ -294,11 +415,11 @@ tl' <- getTagLength BER getASN1Decode body tl' -with'SEQUENCE :: forall x . ASN1Decode x -> ASN1Decode x -with'SEQUENCE = with'Constructed "SEQUENCE" (Universal 16) +dec'SEQUENCE :: forall x . ASN1Decode x -> ASN1Decode x +dec'SEQUENCE = dec'Constructed "SEQUENCE" (Universal 16) -with'SEQUENCE_OF :: forall x . ASN1Decode x -> ASN1Decode [x] -with'SEQUENCE_OF body = asn1DecodeSingleton' (Universal 16) go +dec'SEQUENCE_OF :: forall x . ASN1Decode x -> ASN1Decode [x] +dec'SEQUENCE_OF body = asn1DecodeSingleton' (Universal 16) go where go :: TL -> Get (ASN1Res [x]) go (_,Primitive,_) = fail "SEQUENCE OF with primitive encoding" @@ -316,14 +437,14 @@ 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) + UnexpectedEOF -> fail "dec'SEQUENCE_OF: unexpected EOF" + Unexpected t -> fail ("dec'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 +dec'SET_OF :: forall x . ASN1Decode x -> ASN1Decode [x] +dec'SET_OF body = asn1DecodeSingleton' (Universal 17) go where go :: TL -> Get (ASN1Res [x]) go (_,Primitive,_) = fail "SET OF with primitive encoding" @@ -341,8 +462,8 @@ 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) + UnexpectedEOF -> fail "dec'SET_OF: unexpected EOF" + Unexpected t -> fail ("dec'SET_OF: unexpected " ++ show t) Consumed Nothing <$> loop [] Nothing @@ -387,13 +508,12 @@ 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 +dec'UInt = transformVia dec'INTEGER $ \i -> 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 + Left Underflow -> Left "INTEGER below lower bound" + Left Overflow -> Left "INTEGER above upper bound" + Left _ -> Left "INTEGER" + Right v -> Right 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 @@ -419,16 +539,16 @@ -- | 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) +dec'BoundedEnum = transformVia dec'ENUMERATED $ \i -> + if (i `inside` (lb,ub)) + then Right (toEnum i) + else Left "invalid ENUMERATED value" 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) +enc'BoundedEnum v = enc'ENUMERATED (intCast (fromEnum v) :: Int64) dec'NULL :: ASN1Decode () dec'NULL = asn1DecodeSingleton (Universal 5) $ asPrimitive go @@ -476,64 +596,164 @@ instance Newtype (IMPLICIT tag x) x +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) + -- | 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 +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 @ENUMERATED@ Annotation newtype ENUMERATED x = ENUMERATED x deriving (Generic,NFData,Num,Show,Eq,Ord,Enum) instance Newtype (ENUMERATED x) x +instance Enumerated t => ASN1 (ENUMERATED t) where + asn1defTag _ = Universal 10 + asn1decode = ENUMERATED <$> dec'ENUMERATED + asn1encode (ENUMERATED v) = enc'ENUMERATED v + +-- | ASN.1 @COMPONENTS OF@ Annotation +newtype COMPONENTS_OF x = COMPONENTS_OF x + deriving (Generic,NFData,Show,Eq,Ord) + +instance Newtype (COMPONENTS_OF x) x + +instance ASN1Constructed t => ASN1 (COMPONENTS_OF t) where + asn1defTag _ = asn1defTag (Proxy :: Proxy t) + asn1decode = COMPONENTS_OF <$> asn1decodeCompOf + asn1encode (COMPONENTS_OF v) = asn1encodeCompOf v + +-- | ASN.1 @CHOICE@ Annotation +newtype CHOICE x = CHOICE x + deriving (Generic,NFData,Show,Eq,Ord) + +instance Newtype (CHOICE x) x + +instance (Generic t, GASN1EncodeChoice (Rep t), GASN1DecodeChoice (Rep t)) => ASN1 (CHOICE t) where + asn1defTag _ = undefined + asn1decode = CHOICE <$> gasn1decodeChoice + asn1encode (CHOICE v) = gasn1encodeChoice v + + +instance (ASN1 l, ASN1 r) => ASN1 (Either l r) where + asn1defTag _ = undefined + asn1decode = (Left <$> asn1decode) <|> (Right <$> asn1decode) + asn1encode = either asn1encode asn1encode + ---------------------------------------------------------------------------- class ASN1 t where - asn1decode :: ASN1Decode t - asn1decode = with'Constructed "SEQUENCE" (asn1defTag (Proxy :: Proxy t)) asn1decodeCompOf + -- default-tag + asn1defTag :: Proxy t -> Tag + asn1defTag _ = Universal 16 - asn1decodeCompOf :: ASN1Decode t - asn1decodeCompOf = asn1fail "asn1decodeCompOf not implemented for type" + asn1decode :: ASN1Decode t + default asn1decode :: ASN1Constructed t => ASN1Decode t + asn1decode = dec'Constructed "SEQUENCE" (asn1defTag (Proxy :: Proxy t)) asn1decodeCompOf asn1encode :: t -> ASN1Encode Word64 + default asn1encode :: ASN1Constructed t => t -> ASN1Encode Word64 asn1encode = wraptag (asn1defTag (Proxy :: Proxy t)) . asn1encodeCompOf - -- constructed contents +class ASN1 t => ASN1Constructed t where asn1encodeCompOf :: t -> ASN1Encode Word64 - asn1encodeCompOf = error "asn1encode(CompOf) not implemented for type" + default asn1encodeCompOf :: (Generic t, GASN1EncodeCompOf (Rep t)) => t -> ASN1Encode Word64 + asn1encodeCompOf = gasn1encodeCompOf - -- default-tag - asn1defTag :: Proxy t -> Tag - asn1defTag _ = Universal 16 + asn1decodeCompOf :: ASN1Decode t + default asn1decodeCompOf :: (Generic t, GASN1DecodeCompOf (Rep t)) => ASN1Decode t + asn1decodeCompOf = gasn1decodeCompOf - {-# MINIMAL (asn1decode | asn1decodeCompOf), (asn1encode | asn1encodeCompOf) #-} +gasn1encodeCompOf :: (Generic t, GASN1EncodeCompOf (Rep t)) => t -> ASN1Encode Word64 +gasn1encodeCompOf v = gasn1encodeCompOf' (from v) -instance (ASN1 t1, ASN1 t2) => ASN1 (t1,t2) where +gasn1decodeCompOf :: (Generic t, GASN1DecodeCompOf (Rep t)) => ASN1Decode t +gasn1decodeCompOf = to <$> gasn1decodeCompOf' + +---------------------------------------------------------------------------- + +instance (ASN1 t1, ASN1 t2) => ASN1 (t1,t2) +instance (ASN1 t1, ASN1 t2) => ASN1Constructed (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 +instance (ASN1 t1, ASN1 t2, ASN1 t3) => ASN1 (t1,t2,t3) +instance (ASN1 t1, ASN1 t2, ASN1 t3) => ASN1Constructed (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 +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4) => ASN1 (t1,t2,t3,t4) +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4) => ASN1Constructed (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 +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5) => ASN1 (t1,t2,t3,t4,t5) +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5) => ASN1Constructed (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 +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5, ASN1 t6) => ASN1 (t1,t2,t3,t4,t5,t6) +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5, ASN1 t6) => ASN1Constructed (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 +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5, ASN1 t6, ASN1 t7) => ASN1 (t1,t2,t3,t4,t5,t6,t7) +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5, ASN1 t6, ASN1 t7) => ASN1Constructed (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 +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5, ASN1 t6, ASN1 t7, ASN1 t8) => ASN1 (t1,t2,t3,t4,t5,t6,t7,t8) +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5, ASN1 t6, ASN1 t7, ASN1 t8) => ASN1Constructed (t1,t2,t3,t4,t5,t6,t7,t8) where + asn1encodeCompOf (v1,v2,v3,v4,v5,v6,v7,v8) = enc'SEQUENCE_COMPS [asn1encode v1, asn1encode v2, asn1encode v3, asn1encode v4, asn1encode v5, asn1encode v6, asn1encode v7, asn1encode v8] + asn1decodeCompOf = (,,,,,,,) <$> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode + +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5, ASN1 t6, ASN1 t7, ASN1 t8, ASN1 t9) => ASN1 (t1,t2,t3,t4,t5,t6,t7,t8,t9) +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5, ASN1 t6, ASN1 t7, ASN1 t8, ASN1 t9) => ASN1Constructed (t1,t2,t3,t4,t5,t6,t7,t8,t9) where + asn1encodeCompOf (v1,v2,v3,v4,v5,v6,v7,v8,v9) = enc'SEQUENCE_COMPS [asn1encode v1, asn1encode v2, asn1encode v3, asn1encode v4, asn1encode v5, asn1encode v6, asn1encode v7, asn1encode v8, asn1encode v9] + asn1decodeCompOf = (,,,,,,,,) <$> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode + +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5, ASN1 t6, ASN1 t7, ASN1 t8, ASN1 t9, ASN1 t10) => ASN1 (t1,t2,t3,t4,t5,t6,t7,t8,t9,t10) +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5, ASN1 t6, ASN1 t7, ASN1 t8, ASN1 t9, ASN1 t10) => ASN1Constructed (t1,t2,t3,t4,t5,t6,t7,t8,t9,t10) where + asn1encodeCompOf (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10) = enc'SEQUENCE_COMPS [asn1encode v1, asn1encode v2, asn1encode v3, asn1encode v4, asn1encode v5, asn1encode v6, asn1encode v7, asn1encode v8, asn1encode v9, asn1encode v10] + asn1decodeCompOf = (,,,,,,,,,) <$> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode + +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5, ASN1 t6, ASN1 t7, ASN1 t8, ASN1 t9, ASN1 t10, ASN1 t11) => ASN1 (t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11) +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5, ASN1 t6, ASN1 t7, ASN1 t8, ASN1 t9, ASN1 t10, ASN1 t11) => ASN1Constructed (t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11) where + asn1encodeCompOf (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11) = enc'SEQUENCE_COMPS [asn1encode v1, asn1encode v2, asn1encode v3, asn1encode v4, asn1encode v5, asn1encode v6, asn1encode v7, asn1encode v8, asn1encode v9, asn1encode v10, asn1encode v11] + asn1decodeCompOf = (,,,,,,,,,,) <$> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode + +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5, ASN1 t6, ASN1 t7, ASN1 t8, ASN1 t9, ASN1 t10, ASN1 t11, ASN1 t12) => ASN1 (t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12) +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5, ASN1 t6, ASN1 t7, ASN1 t8, ASN1 t9, ASN1 t10, ASN1 t11, ASN1 t12) => ASN1Constructed (t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12) where + asn1encodeCompOf (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12) = enc'SEQUENCE_COMPS [asn1encode v1, asn1encode v2, asn1encode v3, asn1encode v4, asn1encode v5, asn1encode v6, asn1encode v7, asn1encode v8, asn1encode v9, asn1encode v10, asn1encode v11, asn1encode v12] + asn1decodeCompOf = (,,,,,,,,,,,) <$> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode + +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5, ASN1 t6, ASN1 t7, ASN1 t8, ASN1 t9, ASN1 t10, ASN1 t11, ASN1 t12, ASN1 t13) => ASN1 (t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13) +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5, ASN1 t6, ASN1 t7, ASN1 t8, ASN1 t9, ASN1 t10, ASN1 t11, ASN1 t12, ASN1 t13) => ASN1Constructed (t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13) where + asn1encodeCompOf (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13) = enc'SEQUENCE_COMPS [asn1encode v1, asn1encode v2, asn1encode v3, asn1encode v4, asn1encode v5, asn1encode v6, asn1encode v7, asn1encode v8, asn1encode v9, asn1encode v10, asn1encode v11, asn1encode v12, asn1encode v13] + asn1decodeCompOf = (,,,,,,,,,,,,) <$> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode + +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5, ASN1 t6, ASN1 t7, ASN1 t8, ASN1 t9, ASN1 t10, ASN1 t11, ASN1 t12, ASN1 t13, ASN1 t14) => ASN1 (t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14) +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5, ASN1 t6, ASN1 t7, ASN1 t8, ASN1 t9, ASN1 t10, ASN1 t11, ASN1 t12, ASN1 t13, ASN1 t14) => ASN1Constructed (t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14) where + asn1encodeCompOf (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14) = enc'SEQUENCE_COMPS [asn1encode v1, asn1encode v2, asn1encode v3, asn1encode v4, asn1encode v5, asn1encode v6, asn1encode v7, asn1encode v8, asn1encode v9, asn1encode v10, asn1encode v11, asn1encode v12, asn1encode v13, asn1encode v14] + asn1decodeCompOf = (,,,,,,,,,,,,,) <$> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode + +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5, ASN1 t6, ASN1 t7, ASN1 t8, ASN1 t9, ASN1 t10, ASN1 t11, ASN1 t12, ASN1 t13, ASN1 t14, ASN1 t15) => ASN1 (t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15) +instance (ASN1 t1, ASN1 t2, ASN1 t3, ASN1 t4, ASN1 t5, ASN1 t6, ASN1 t7, ASN1 t8, ASN1 t9, ASN1 t10, ASN1 t11, ASN1 t12, ASN1 t13, ASN1 t14, ASN1 t15) => ASN1Constructed (t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15) where + asn1encodeCompOf (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15) = enc'SEQUENCE_COMPS [asn1encode v1, asn1encode v2, asn1encode v3, asn1encode v4, asn1encode v5, asn1encode v6, asn1encode v7, asn1encode v8, asn1encode v9, asn1encode v10, asn1encode v11, asn1encode v12, asn1encode v13, asn1encode v14, asn1encode v15] + asn1decodeCompOf = (,,,,,,,,,,,,,,) <$> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode <*> asn1decode + + -- | ASN.1 @OCTET STRING@ type type OCTET_STRING = ByteString @@ -549,11 +769,16 @@ instance ASN1 ShortText where asn1defTag _ = Universal 4 - asn1decode = do - bs <- dec'OCTETSTRING - maybe (asn1fail "OCTECT STRING contained invalid UTF-8") pure (TS.fromByteString bs) + asn1decode = dec'OCTETSTRING `transformVia` + (maybe (Left "OCTECT STRING contained invalid UTF-8") Right . TS.fromByteString) asn1encode = asn1encode . TS.toShortByteString +instance ASN1 Text where + asn1defTag _ = Universal 4 + asn1decode = dec'OCTETSTRING `transformVia` + (either (\_ -> Left "OCTECT STRING contained invalid UTF-8") Right . T.decodeUtf8') + asn1encode = asn1encode . T.encodeUtf8 + type BOOLEAN = Bool instance ASN1 Bool where @@ -565,25 +790,21 @@ instance ASN1 t => ASN1 (Maybe t) where asn1defTag _ = asn1defTag (Proxy :: Proxy t) - asn1decode = with'OPTIONAL asn1decode + asn1decode = dec'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 + asn1decode = dec'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) + asn1decode = transformVia asn1decode $ \case + [] -> Left "SEQUENCE (1..n) must be non-empty" + x:xs -> Right (x :| xs) asn1encode (x :| xs) = asn1encode (x:xs) @@ -595,9 +816,9 @@ 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)) + asn1decode = transformVia asn1decode $ \case + SET [] -> Left "SET (1..n) must be non-empty" + SET (x:xs) -> Right (SET1 (x :| xs)) asn1encode (SET1 (x :| xs)) = asn1encode (SET (x:xs)) @@ -609,7 +830,7 @@ instance ASN1 t => ASN1 (SET t) where asn1defTag _ = Universal 17 - asn1decode = SET <$> with'SET_OF asn1decode + asn1decode = SET <$> dec'SET_OF asn1decode asn1encode (SET vs) = enc'SET (map asn1encode vs) instance ASN1 Integer where @@ -627,16 +848,6 @@ 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 = () @@ -646,26 +857,104 @@ 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) +-- | Helper representing a @BOOLEAN DEFAULT (TRUE|FALSE)@ ASN.1 type annotation +newtype BOOLEAN_DEFAULT (def :: Bool) = BOOLEAN Bool + deriving (Eq,Ord,Bounded,Enum,Generic,Show,Read,NFData) -instance NFData BOOLEAN_DEFAULT_FALSE where - rnf BOOL_TRUE = () +instance forall def . KnownBool def => ASN1 (BOOLEAN_DEFAULT def) where + asn1defTag _ = Universal 1 -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 + asn1encode (BOOLEAN b) + | b == boolVal (Proxy :: Proxy def) = ASN1Encode $ \_ -> pure 0 + | otherwise = asn1encode b + + asn1decode = transformVia (dec'OPTIONAL dec'BOOLEAN) $ \case + Just True | defbool -> Left "encoded TRUE encountered despite 'BOOLEAN DEFAULT TRUE'" + Just False | not defbool -> Left "encoded FALSE encountered despite 'BOOLEAN DEFAULT FALSE'" + Just b -> Right (BOOLEAN b) + Nothing -> Right (BOOLEAN defbool) + where + defbool = boolVal (Proxy :: Proxy def) + +class KnownBool (b :: Bool) where boolVal :: Proxy b -> Bool +instance KnownBool 'True where boolVal _ = True +instance KnownBool 'False where boolVal _ = False + +---------------------------------------------------------------------------- +-- Generics support + +---------------------------------- +-- product types (i.e. SEQUENCE) + +class GASN1EncodeCompOf (t :: * -> *) where + gasn1encodeCompOf' :: t p -> ASN1Encode Word64 + +-- instance GASN1EncodeCompOf U1 where gasn1encodeCompOf' _ = error "GASN1EncodeCompOf U1" +-- instance GASN1EncodeCompOf V1 where gasn1encodeCompOf' _ = error "GASN1EncodeCompOf V1" + +instance ASN1 a => GASN1EncodeCompOf (K1 i a) where + gasn1encodeCompOf' (K1 v) = asn1encode v + +instance GASN1EncodeCompOf f => GASN1EncodeCompOf (M1 i c f) where + gasn1encodeCompOf' (M1 x) = gasn1encodeCompOf' x + +instance (GASN1EncodeCompOf f, GASN1EncodeCompOf g) => GASN1EncodeCompOf (f :*: g) where + gasn1encodeCompOf' (x1 :*: x2) = gasn1encodeCompOf' x1 <> gasn1encodeCompOf' x2 + + +class GASN1DecodeCompOf (t :: * -> *) where + gasn1decodeCompOf' :: ASN1Decode (t p) + +-- instance GASN1DecodeCompOf U1 where gasn1decodeCompOf' _ = error "GASN1DecodeCompOf U1" +-- instance GASN1DecodeCompOf V1 where gasn1decodeCompOf' _ = error "GASN1DecodeCompOf V1" + +instance ASN1 a => GASN1DecodeCompOf (K1 i a) where + gasn1decodeCompOf' = K1 <$> asn1decode + +instance GASN1DecodeCompOf f => GASN1DecodeCompOf (M1 i c f) where + gasn1decodeCompOf' = M1 <$> gasn1decodeCompOf' + +instance (GASN1DecodeCompOf f, GASN1DecodeCompOf g) => GASN1DecodeCompOf (f :*: g) where + gasn1decodeCompOf' = (:*:) <$> gasn1decodeCompOf' <*> gasn1decodeCompOf' + + +---------------------------- +-- sum types (i.e. CHOICE) + +gasn1encodeChoice :: (Generic t, GASN1EncodeChoice (Rep t)) => t -> ASN1Encode Word64 +gasn1encodeChoice x = gchoice (from x) + +class GASN1EncodeChoice (t :: * -> *) where + gchoice :: t p -> ASN1Encode Word64 + +instance GASN1EncodeChoice V1 where + gchoice _ = empty'ASN1Encode + +instance GASN1EncodeChoice f => GASN1EncodeChoice (M1 i c f) where + gchoice (M1 x) = gchoice x + +instance ASN1 a => GASN1EncodeChoice (K1 i a) where + gchoice (K1 x) = asn1encode x + +instance (GASN1EncodeChoice x, GASN1EncodeChoice y) => GASN1EncodeChoice (x :+: y) where + gchoice (L1 x) = gchoice x + gchoice (R1 x) = gchoice x + + +gasn1decodeChoice :: (Generic t, GASN1DecodeChoice (Rep t)) => ASN1Decode t +gasn1decodeChoice = to <$> gunchoice + +class GASN1DecodeChoice (t :: * -> *) where + gunchoice :: ASN1Decode (t p) + +instance GASN1DecodeChoice V1 where + gunchoice = empty + +instance GASN1DecodeChoice f => GASN1DecodeChoice (M1 i c f) where + gunchoice = M1 <$> gunchoice + +instance ASN1 a => GASN1DecodeChoice (K1 i a) where + gunchoice = K1 <$> asn1decode + +instance (GASN1DecodeChoice x, GASN1DecodeChoice y) => GASN1DecodeChoice (x :+: y) where + gunchoice = (L1 <$> gunchoice) <|> (R1 <$> gunchoice) diff --git a/src/Data/ASN1/Prim.hs b/src/Data/ASN1/Prim.hs --- a/src/Data/ASN1/Prim.hs +++ b/src/Data/ASN1/Prim.hs @@ -45,10 +45,11 @@ ) where import Common +import Data.Int.Subtypes -import Data.Binary as Bin -import Data.Binary.Get as Bin -import Data.Binary.Put as Bin +import Data.Binary as Bin +import Data.Binary.Get as Bin +import Data.Binary.Put as Bin data TagPC = Primitive @@ -98,7 +99,7 @@ !tn <- case n0 of 0x1f -> getXTagNum -- long-form tag-number - _ -> pure (fromIntegral n0) + _ -> pure (intCast n0) case b0 .&. 0xc0 of 0x00 -> pure (Universal tn, pc) @@ -129,7 +130,7 @@ getXTagNum :: Get Word64 getXTagNum = do (more0,n0) <- getWord7 - let n0' = fromIntegral n0 + let n0' = intCast n0 when (n0' == 0) $ fail "lower 7 bits of the first subsequent tag-number octet shall not all be zero" @@ -142,7 +143,7 @@ go :: Word64 -> Get Word64 go !acc = do (mo,o7) <- getWord7 - let acc' = (acc `shiftL` 7) .|. fromIntegral o7 + let acc' = (acc `shiftL` 7) .|. intCast o7 when (acc >= 0x0200000000000000) $ fail "tag number exceeds 64bit range" -- TODO: investigate whether there's ASN.1 schemas requiring larger tag-numbers @@ -163,7 +164,7 @@ xb7 <- getWord7 case xb7 of -- definite short-form - (False,n) -> pure $! Just $! fromIntegral n + (False,n) -> pure $! Just $! intCast n -- indefinite (True,0) -> pure Nothing @@ -184,7 +185,7 @@ x <- getWord8 - let acc' = (acc `shiftL` 8) .|. fromIntegral x + let acc' = (acc `shiftL` 8) .|. intCast x when (minimal && acc == 0 && x == 0) $ fail "length not encoded minimally" @@ -202,7 +203,6 @@ 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" @@ -214,38 +214,38 @@ getInt24be = do hi <- getInt8 lo <- getWord16be - pure $! (fromIntegral hi `shiftL` 16) + fromIntegral lo + pure $! (intCast hi `shiftL` 16) + intCast lo getInt40be :: Get Int64 getInt40be = do hi <- getInt8 lo <- getWord32be - pure $! (fromIntegral hi `shiftL` 32) + fromIntegral lo + pure $! (intCast hi `shiftL` 32) + intCast lo getInt48be :: Get Int64 getInt48be = do hi <- getInt16be lo <- getWord32be - pure $! (fromIntegral hi `shiftL` 32) + fromIntegral lo + pure $! (intCast hi `shiftL` 32) + intCast lo getInt56be :: Get Int64 getInt56be = do hi <- getInt24be lo <- getWord32be - pure $! (fromIntegral hi `shiftL` 32) + fromIntegral lo + pure $! (intCast hi `shiftL` 32) + intCast 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 + 1 -> intCast <$> getInt8 + 2 -> intCast <$> getInt16be + 3 -> intCast <$> getInt24be + 4 -> intCast <$> getInt32be + 5 -> getInt40be + 6 -> getInt48be + 7 -> getInt56be + 8 -> getInt64be _ -> fail "INTEGER too large for type" getVarInteger :: Word64 -> Get Integer @@ -321,16 +321,16 @@ class KnownTag (tag :: TagK) where tagVal :: Proxy tag -> Tag -instance forall n . (KnownNat n) => KnownTag ('UNIVERSAL n) where +instance forall n . (KnownNat n, IsBelowMaxBound n (IntBaseType Word64) ~ 'True) => KnownTag ('UNIVERSAL n) where tagVal _ = Universal (fromIntegral $ natVal (Proxy :: Proxy n)) -instance forall n . (KnownNat n) => KnownTag ('APPLICATION n) where +instance forall n . (KnownNat n, IsBelowMaxBound n (IntBaseType Word64) ~ 'True) => KnownTag ('APPLICATION n) where tagVal _ = Application (fromIntegral $ natVal (Proxy :: Proxy n)) -instance forall n . (KnownNat n) => KnownTag ('CONTEXTUAL n) where +instance forall n . (KnownNat n, IsBelowMaxBound n (IntBaseType Word64) ~ 'True) => KnownTag ('CONTEXTUAL n) where tagVal _ = Contextual (fromIntegral $ natVal (Proxy :: Proxy n)) -instance forall n . (KnownNat n) => KnownTag ('PRIVATE n) where +instance forall n . (KnownNat n, IsBelowMaxBound n (IntBaseType Word64) ~ 'True) => KnownTag ('PRIVATE n) where tagVal _ = Private (fromIntegral $ natVal (Proxy :: Proxy n)) ---------------------------------------------------------------------------- diff --git a/src/Data/Int/Subtypes.hs b/src/Data/Int/Subtypes.hs --- a/src/Data/Int/Subtypes.hs +++ b/src/Data/Int/Subtypes.hs @@ -23,7 +23,7 @@ {-# LANGUAGE UndecidableInstances #-} module Data.Int.Subtypes - ( UInt(..), toUInt, fromUInt, uintFromInteger + ( UInt(..), toUInt, toUInt', fromUInt, uintFromInteger , SInt(..), toSInt, fromSInt, sintFromInteger , UIntBounds @@ -112,7 +112,7 @@ -- | Try to coerce a base-type into its 'UInt' sub-type -- --- If out of range, @'Left' 'Underflow'@ or @'Right' 'Overflow'@ will be returned. +-- If out of range, @'Left' 'Underflow'@ or @'Left' 'Overflow'@ will be returned respectively. 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 diff --git a/src/LDAPv3.hs b/src/LDAPv3.hs deleted file mode 100644 --- a/src/LDAPv3.hs +++ /dev/null @@ -1,1180 +0,0 @@ --- Copyright (c) 2019 Herbert Valerio Riedel --- --- This file is free software: you may copy, redistribute and/or modify it --- under the terms of the GNU General Public License as published by the --- Free Software Foundation, either version 2 of the License, or (at your --- option) any later version. --- --- This file is distributed in the hope that it will be useful, but --- WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program (see `LICENSE`). If not, see --- . - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE 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 . --- --- Serializing and deserializing to and from the wire encoding is provided via the 'Bin.Binary' instance of 'LDAPMessage'. For the purpose of implementing network clients and servers, the operations --- --- * 'Bin.encode' --- * '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 . - -- - -- For convenience, the normative definitions for each Haskell data type are quoted. - - -- ** Common Elements () - - -- 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 () - - , BindRequest(..) - , AuthenticationChoice(..) - , SaslCredentials(..) - , BindResponse(..) - - -- ** Unbind Operation () - - , UnbindRequest - - -- ** Unsolicited Notification () - -- - -- | Unsolicited notifications are represented by an 'ExtendedResponse' message with its 'MessageID' set to @0@. - - -- ** Search Operation () - - , SearchRequest(..) - , Scope(..) - , DerefAliases(..) - , AttributeSelection - , Filter(..) - , SubstringFilter(..) - , Substring(..) - , MatchingRuleAssertion(..) - - -- *** Search Result () - - , SearchResultEntry(..) - , PartialAttributeList - , SearchResultReference(..) - , SearchResultDone - - -- ** Modify Operation () - - , ModifyRequest(..) - , Change(..) - , Operation(..) - , ModifyResponse - - -- ** Add Operation () - - , AddRequest(..) - , AttributeList - , AddResponse - - -- ** Delete Operation () - - , DelRequest - , DelResponse - - -- ** Modify DN Operation () - - , ModifyDNRequest(..) - , ModifyDNResponse - - -- ** Compare Operation () - - , CompareRequest(..) - , CompareResponse - - -- ** Abandon Operation () - - , AbandonRequest - - -- ** Extended Operation () - - , ExtendedRequest(..) - , ExtendedResponse(..) - - -- ** Intermediate Response () - - , 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 () - -> 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 -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 () - -> 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 - -> maxInt INTEGER ::= 2147483647 -- (2^^31 - 1) - --} -type MaxInt = 2147483647 - --- | @CHOICE@ type inlined in @LDAPMessage.protocolOp@ () --- -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 () - -> Controls ::= SEQUENCE OF control Control - --} -type Controls = [Control] - -{- | Control Entry () - -> 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 () - -> LDAPOID ::= OCTET STRING -- Constrained to -> -- [RFC4512] - --} -type LDAPOID = OCTET_STRING - ----------------------------------------------------------------------------- - -{- | Bind Request () - -> 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 () - -> 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 () - -> UnbindRequest ::= [APPLICATION 2] NULL - --} -type UnbindRequest = ('APPLICATION 2 `IMPLICIT` NULL) - ----------------------------------------------------------------------------- - -{- | Search Request () - -> 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 -> -- 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' () -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' () -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 () - -> 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 () - -> AttributeDescription ::= LDAPString -> -- Constrained to -> -- [RFC4512] - --} -type AttributeDescription = LDAPString - -{- | Attribute Value () - -> AttributeValue ::= OCTET STRING - --} -type AttributeValue = OCTET_STRING - -{- | Attribute Value Assertion () - -> 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' () - -> 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 () - -> 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 () - -> 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 () - -> 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 () - -> 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 () - -> 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 () - -> SearchResultDone ::= [APPLICATION 5] LDAPResult - --} -type SearchResultDone = ('APPLICATION 5 `IMPLICIT` LDAPResult) - ----------------------------------------------------------------------------- - -{- | Result Message () - -> 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 () - -> 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 () - -> LDAPString ::= OCTET STRING -- UTF-8 encoded, -> -- [ISO10646] characters - --} -type LDAPString = ShortText - -{- | Distinguished Name () - -> LDAPDN ::= LDAPString -- Constrained to -> -- [RFC4514] - --} -type LDAPDN = LDAPString - -{- | Relative Distinguished Name () - -> RelativeLDAPDN ::= LDAPString -- Constrained to -> -- [RFC4514] - --} -type RelativeLDAPDN = LDAPString - -{- | Modify Operation () - -> 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 () - -> ModifyResponse ::= [APPLICATION 7] LDAPResult - --} -type ModifyResponse = ('APPLICATION 7 `IMPLICIT` LDAPResult) - -{- | Add Operation () - -> 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 () - -> AddResponse ::= [APPLICATION 9] LDAPResult - --} -type AddResponse = ('APPLICATION 9 `IMPLICIT` LDAPResult) - - -{- | Delete Operation () - -> DelRequest ::= [APPLICATION 10] LDAPDN - --} -type DelRequest = ('APPLICATION 10 `IMPLICIT` LDAPDN) - -{- | Delete Response () - -> DelResponse ::= [APPLICATION 11] LDAPResult - --} -type DelResponse = ('APPLICATION 11 `IMPLICIT` LDAPResult) - -{- | Modify DN Operation () - -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 () - -> ModifyDNResponse ::= [APPLICATION 13] LDAPResult - --} -type ModifyDNResponse = ('APPLICATION 13 `IMPLICIT` LDAPResult) - - -{- | Compare Operation () - -> 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 () - -> CompareResponse ::= [APPLICATION 15] LDAPResult - --} -type CompareResponse = ('APPLICATION 15 `IMPLICIT` LDAPResult) - - -{- | Abandon Operation () - -> AbandonRequest ::= [APPLICATION 16] MessageID - --} -type AbandonRequest = ('APPLICATION 16 `IMPLICIT` MessageID) - -{- | Extended Request () - -> 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 () - -> 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 () - -> 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) diff --git a/src/LDAPv3/AttributeDescription.hs b/src/LDAPv3/AttributeDescription.hs new file mode 100644 --- /dev/null +++ b/src/LDAPv3/AttributeDescription.hs @@ -0,0 +1,303 @@ +-- Copyright (c) 2019 Herbert Valerio Riedel +-- +-- This file is free software: you may copy, redistribute and/or modify it +-- under the terms of the GNU General Public License as published by the +-- Free Software Foundation, either version 2 of the License, or (at your +-- option) any later version. +-- +-- This file is distributed in the hope that it will be useful, but +-- WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see `LICENSE`). If not, see +-- . + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- internal module +module LDAPv3.AttributeDescription + ( AttributeDescription(..) + , p'AttributeDescription + , ts'AttributeDescription + , r'AttributeDescription + + , Option + , p'Option + , ts'Option + + , KeyString + , p'KeyString + , ts'KeyString + + , MatchingRuleId(..) + , p'MatchingRuleId + , ts'MatchingRuleId + , r'MatchingRuleId + + , OID(..) + , p'OID + , ts'OID + , r'OID + ) where + +import Common hiding (Option, many, option, some, (<|>)) +import Data.ASN1 + +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Short as SBS +import Data.Char (isDigit, toLower) +import Data.List +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.String as S +import Data.Text.Lazy.Builder as B +import qualified Data.Text.Short as TS +import Text.Parsec as P + +{- | Attribute Descriptions () + +> AttributeDescription ::= LDAPString +> -- Constrained to +> -- [RFC4512] + +@attributedescription@'s syntax is defined in ABNF () notation as + +> attributedescription = attributetype options +> attributetype = oid +> options = *( SEMI option ) +> option = 1*keychar +> oid = descr / numericoid +> +> descr = keystring +> numericoid = number 1*( DOT number ) +> keystring = leadkeychar *keychar +> leadkeychar = ALPHA +> keychar = ALPHA / DIGIT / HYPHEN +> ALPHA = %x41-5A / %x61-7A ; "A"-"Z" / "a"-"z" +> number = DIGIT / ( LDIGIT 1*DIGIT ) +> DIGIT = %x30 / LDIGIT ; "0"-"9" +> LDIGIT = %x31-39 ; "1"-"9" +> HYPHEN = %x2D ; hyphen ("-") + +See also for the definition of @attributedescription@. + +-} +data AttributeDescription = AttributeDescription (Either KeyString OID) (Set Option) + deriving (Eq,Ord,Show,Generic) + +instance NFData AttributeDescription where + rnf (AttributeDescription k o) = rnf (k,o) + +instance ASN1 AttributeDescription where + asn1defTag _ = asn1defTag (Proxy :: Proxy OCTET_STRING) + asn1decode = asn1decodeParsec "AttributeDescription" p'AttributeDescription + asn1encode = asn1encode . ts'AttributeDescription + +instance S.IsString AttributeDescription where + fromString = _fromString "AttributeDescription" p'AttributeDescription + +_fromString :: Stream s Identity Char => [Char] -> ParsecT s () Identity x -> s -> x +_fromString l p = either (error ("invalid " ++ l ++ " string literal")) id . parse (p <* eof) "" + +-- attributedescription = attributetype options +-- attributetype = oid +p'AttributeDescription :: Stream s Identity Char => Parsec s () AttributeDescription +p'AttributeDescription = AttributeDescription <$> p'DescrOrOID <*> (Set.fromList <$> p'options) + where + -- options = *( SEMI option ) + p'options = many (char ';' *> p'Option) + +r'AttributeDescription :: AttributeDescription -> Builder +r'AttributeDescription = b'ShortText . ts'AttributeDescription + +ts'AttributeDescription :: AttributeDescription -> ShortText +ts'AttributeDescription (AttributeDescription key opts) + | Set.null opts = k + | otherwise = TS.intercalate ";" (k:[ o | Option o <- Set.toList opts]) + where + k = ts'DescrOrOID key + +{- | Case-insensitive attribute description option + +> option = 1*keychar +> keychar = ALPHA / DIGIT / HYPHEN +> ALPHA = %x41-5A / %x61-7A ; "A"-"Z" / "a"-"z" +> DIGIT = %x30 / LDIGIT ; "0"-"9" +> HYPHEN = %x2D ; hyphen ("-") + +-} +newtype Option = Option ShortText + deriving (NFData) + +instance Eq Option where + Option x == Option y = x `eqCI` y + +instance Ord Option where + Option x `compare` Option y = x `cmpCI` y + +instance Show Option where + showsPrec p (Option s) = showsPrec p s + show (Option s) = show s + +instance S.IsString Option where + fromString = _fromString "Option" p'Option + +-- option = 1*keychar +p'Option :: Stream s Identity Char => Parsec s () Option +p'Option = Option . TS.fromString <$> many1 p'keychar + +ts'Option :: Option -> ShortText +ts'Option (Option s) = s + +-- oid = descr / numericoid +-- descr = keystring +p'DescrOrOID :: Stream s Identity Char => Parsec s () (Either KeyString OID) +p'DescrOrOID = ((Left <$> p'KeyString) <|> (Right <$> p'OID)) "oid" + +ts'DescrOrOID :: Either KeyString OID -> ShortText +ts'DescrOrOID = \case + Left (KeyString s) -> s + Right oid -> TS.fromString (s'OID oid) + +{- | Numeric Object Identifier (OID) + +> numericoid = number 1*( DOT number ) +> number = DIGIT / ( LDIGIT 1*DIGIT ) +> DIGIT = %x30 / LDIGIT ; "0"-"9" +> LDIGIT = %x31-39 ; "1"-"9" + +-} +newtype OID = OID (NonEmpty Natural) + deriving (Eq,Ord,Show,NFData) + +instance Newtype OID (NonEmpty Natural) + +instance ASN1 OID where + asn1defTag _ = asn1defTag (Proxy :: Proxy OCTET_STRING) + asn1encode oid = asn1encode (BSC.pack (s'OID oid)) + asn1decode = asn1decodeParsec "OID" p'OID + +r'OID :: OID -> Builder +r'OID = B.fromString . s'OID + +ts'OID :: OID -> ShortText +ts'OID = TS.fromString . s'OID + +s'OID :: OID -> String +s'OID (OID (x:|xs)) = intercalate "." (map show (x:xs)) + + +p'OID :: Stream s Identity Char => Parsec s () OID +p'OID = p'numericoid + where + -- numericoid = number 1*( DOT number ) + p'numericoid = OID <$> (p'number `sepBy1'` char '.') + + -- number = DIGIT / ( LDIGIT 1*DIGIT ) + -- DIGIT = %x30 / LDIGIT ; "0"-"9" + -- LDIGIT = %x31-39 ; "1"-"9" + p'number = do + ldigit <- digit + if ldigit == '0' + then pure 0 + else read . (ldigit:) <$> many digit + + sepBy1' p set = f <$> sepBy1 p set + where + f [] = error "the impossible happened" + f (x:xs) = x:|xs + +{- | Case-insensitive string used to denote OID short names + +> keystring = leadkeychar *keychar +> leadkeychar = ALPHA +> keychar = ALPHA / DIGIT / HYPHEN +> ALPHA = %x41-5A / %x61-7A ; "A"-"Z" / "a"-"z" +> DIGIT = %x30 / LDIGIT ; "0"-"9" +> HYPHEN = %x2D ; hyphen ("-") + +-} +newtype KeyString = KeyString ShortText + deriving (NFData) + +instance Eq KeyString where + KeyString x == KeyString y = x `eqCI` y + +instance Ord KeyString where + KeyString x `compare` KeyString y = x `cmpCI` y + +instance Show KeyString where + showsPrec p (KeyString s) = showsPrec p s + show (KeyString s) = show s + +instance S.IsString KeyString where + fromString = _fromString "KeyString" p'KeyString + +ts'KeyString :: KeyString -> ShortText +ts'KeyString (KeyString s) = s + +p'KeyString :: Stream s Identity Char => Parsec s () KeyString +p'KeyString = KeyString . TS.fromString <$> p'keystring + where + -- keystring = leadkeychar *keychar + -- leadkeychar = ALPHA + p'keystring = (:) <$> p'ALPHA <*> many p'keychar + + -- ALPHA = %x41-5A / %x61-7A ; "A"-"Z" / "a"-"z" + p'ALPHA = satisfy (\c -> (c `inside` ('A','Z')) || (c `inside` ('a','z'))) "ALPHA" + + +-- keychar = ALPHA / DIGIT / HYPHEN +p'keychar :: Stream s Identity Char => Parsec s () Char +p'keychar = satisfy (\c -> (c `inside` ('A','Z')) || (c `inside` ('a','z')) || isDigit c || c == '-') + + +b'ShortText :: ShortText -> Builder +b'ShortText = fromText . TS.toText + +{- | Matching Rule Identifier () + +> MatchingRuleId ::= LDAPString + +-} +newtype MatchingRuleId = MatchingRuleId (Either KeyString OID) + deriving (Generic,Show,Eq,Ord,NFData) + +instance ASN1 MatchingRuleId where + asn1defTag _ = asn1defTag (Proxy :: Proxy OCTET_STRING) + asn1encode (MatchingRuleId v) = asn1encode (ts'DescrOrOID v) + asn1decode = asn1decodeParsec "MatchingRuleId" p'MatchingRuleId + +instance S.IsString MatchingRuleId where + fromString = _fromString "MatchingRuleId" p'MatchingRuleId + +ts'MatchingRuleId :: MatchingRuleId -> ShortText +ts'MatchingRuleId (MatchingRuleId mrid) = ts'DescrOrOID mrid + +r'MatchingRuleId :: MatchingRuleId -> Builder +r'MatchingRuleId = b'ShortText . ts'MatchingRuleId + +p'MatchingRuleId :: Stream s Identity Char => Parsec s () MatchingRuleId +p'MatchingRuleId = MatchingRuleId <$> p'DescrOrOID + + + +eqCI :: ShortText -> ShortText -> Bool +eqCI x y + | x == y = True + | SBS.length (TS.toShortByteString x) /= SBS.length (TS.toShortByteString y) = False + | otherwise = map toLower (TS.toString x) == map toLower (TS.toString y) + +cmpCI :: ShortText -> ShortText -> Ordering +cmpCI x y + | x == y = EQ + | otherwise = map toLower (TS.toString x) `compare` map toLower (TS.toString y) diff --git a/src/LDAPv3/Message.hs b/src/LDAPv3/Message.hs new file mode 100644 --- /dev/null +++ b/src/LDAPv3/Message.hs @@ -0,0 +1,1127 @@ +-- Copyright (c) 2019 Herbert Valerio Riedel +-- +-- This file is free software: you may copy, redistribute and/or modify it +-- under the terms of the GNU General Public License as published by the +-- Free Software Foundation, either version 2 of the License, or (at your +-- option) any later version. +-- +-- This file is distributed in the hope that it will be useful, but +-- WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see `LICENSE`). If not, see +-- . + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} + +#if !defined(HS_LDAPv3_ANNOTATED) +{-# OPTIONS_GHC -fno-warn-dodgy-exports #-} +#endif + +-- This module is compiled twice; once with ASN.1 type-annotating +-- `newtype` wrappers; and a 2nd time with those newtypes made +-- "transparent" by redefining them as `type` synonyms. The public API +-- exposes the latter version; ASN.1 encoding/decoding goes via the +-- former version. + +#if defined(HS_LDAPv3_ANNOTATED) +# define MODULE_NAME LDAPv3.Message.Annotated +#else +# define MODULE_NAME LDAPv3.Message +#endif + +-- | This module provides a pure Haskell implementation of the /Lightweight Directory Access Protocol (LDAP)/ version 3 as specified in . +-- +-- Serializing and deserializing to and from the wire encoding is provided via the 'Bin.Binary' instance of 'LDAPMessage'. For the purpose of implementing network clients and servers, the operations +-- +-- * 'Bin.encode' +-- * 'Data.Binary.Get.runGetIncremental' +-- +-- are most useful. +-- +-- When using a streaming I\/O framework such a simple 'Data.Binary.Binary' adapter such as makes it easy to implement a LDAPv3 client. +-- +-- @since 0.1.0 + +module MODULE_NAME + ( -- * LDAPv3 Protocol data structures + -- + -- | The Haskell data structures defined in this module closely follow the protocol specification as laid out in . + -- + -- For convenience, the normative definitions for each Haskell data type are quoted. + + -- ** Common Elements () + + -- 4.1.1. Message Envelope + LDAPMessage(..) + , MessageID(..) + , MaxInt + , ProtocolOp(..) + + -- 4.1.2. String Types + , LDAPString + , LDAPOID + , OID(..) + -- 4.1.3. Distinguished Name and Relative Distinguished Name + , LDAPDN + , RelativeLDAPDN + -- 4.1.4. Attribute Descriptions + , AttributeDescription(..) + , KeyString + , Option + -- 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 () + + , BindRequest(..) + , AuthenticationChoice(..) + , SaslCredentials(..) + , BindResponse(..) + + -- ** Unbind Operation () + + , UnbindRequest + + -- ** Unsolicited Notification () + -- + -- | Unsolicited notifications are represented by an 'ExtendedResponse' message with its 'MessageID' set to @0@. + + -- ** Search Operation () + + , SearchRequest(..) + , Scope(..) + , DerefAliases(..) + , AttributeSelection + , Filter(..) + , SubstringFilter(..) + , Substring(..) + , MatchingRuleAssertion(..) + + -- *** Search Result () + + , SearchResultEntry(..) + , PartialAttributeList + , SearchResultReference(..) + , SearchResultDone + + -- ** Modify Operation () + + , ModifyRequest(..) + , Change(..) + , Operation(..) + , ModifyResponse + + -- ** Add Operation () + + , AddRequest(..) + , AttributeList + , AddResponse + + -- ** Delete Operation () + + , DelRequest + , DelResponse + + -- ** Modify DN Operation () + + , ModifyDNRequest(..) + , ModifyDNResponse + + -- ** Compare Operation () + + , CompareRequest(..) + , CompareResponse + + -- ** Abandon Operation () + + , AbandonRequest + + -- ** Extended Operation () + + , ExtendedRequest(..) + , ExtendedResponse(..) + + -- ** Intermediate Response () + + , IntermediateResponse(..) + + -- * ASN.1 Helpers + , NULL + , OCTET_STRING + , BOOLEAN_DEFAULT(..) + , SET(..) + , SET1(..) + , COMPONENTS_OF(..) + + -- ** ASN.1 type-level tagging + , EXPLICIT(..) + , IMPLICIT(..) + , ENUMERATED(..) + , CHOICE(..) + , TagK(..) + + -- * Unsigned integer sub-type + , UIntBounds + , UInt + , fromUInt + , toUInt + ) where + +import Common hiding (Option) +import Data.ASN1.Prim (TagK (..)) +import Data.Int.Subtypes +import LDAPv3.AttributeDescription +import LDAPv3.Message.Types +import LDAPv3.ResultCode + +import qualified Data.Binary as Bin + +import Data.ASN1 (Enumerated, NULL, OCTET_STRING, SET (..), SET1 (..)) +#if defined(HS_LDAPv3_ANNOTATED) +import Data.ASN1 (ASN1 (..), ASN1Constructed, BOOLEAN_DEFAULT (..), CHOICE (..), + COMPONENTS_OF (..), ENUMERATED (..), EXPLICIT (..), + IMPLICIT (..), gasn1decodeChoice, gasn1encodeChoice, + toBinaryGet, toBinaryPut) +import Data.ASN1.Prim (Tag (..)) +#else /* defined(HS_LDAPv3_ANNOTATED) */ +import qualified LDAPv3.Message.Annotated as Annotated (LDAPMessage) +import Unsafe.Coerce (unsafeCoerce) + +-- | ASN.1 @IMPLICIT@ Annotation +type IMPLICIT (tag :: TagK) x = x + +-- | ASN.1 @EXPLICIT@ Annotation +type EXPLICIT (tag :: TagK) x = x + +-- | ASN.1 @ENUMERATED@ Annotation +type ENUMERATED x = x + +-- | Helper representing a @BOOLEAN DEFAULT (TRUE|FALSE)@ ASN.1 type annotation +type BOOLEAN_DEFAULT (def :: Bool) = Bool + +-- | ASN.1 @COMPONENTS OF@ Annotation +type COMPONENTS_OF x = x + +-- | ASN.1 @CHOICE@ Annotation +type CHOICE x = x + +#endif /* defined(HS_LDAPv3_ANNOTATED) */ + +---------------------------------------------------------------------------- +-- LDAPv3 protocol + +{- | Message Envelope () + +> 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 :: CHOICE ProtocolOp + , _LDAPMessage'controls :: Maybe ('CONTEXTUAL 0 `IMPLICIT` Controls) + } deriving (Generic,Show,Eq) + +-- | Encodes to\/from ASN.1 as per +#if defined(HS_LDAPv3_ANNOTATED) +instance Bin.Binary LDAPMessage where + put = void . toBinaryPut . asn1encode + get = toBinaryGet asn1decode +#else +instance Bin.Binary LDAPMessage where + put = Bin.put . (unsafeCoerce :: LDAPMessage -> Annotated.LDAPMessage) + get = (unsafeCoerce :: Annotated.LDAPMessage -> LDAPMessage) <$> Bin.get +#endif + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 LDAPMessage +instance ASN1Constructed LDAPMessage +#endif + +-- | @CHOICE@ type inlined in @LDAPMessage.protocolOp@ () +-- +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 + +---------------------------------------------------------------------------- + +{- | Controls () + +> Controls ::= SEQUENCE OF control Control + +-} +type Controls = [Control] + +{- | Control Entry () + +> Control ::= SEQUENCE { +> controlType LDAPOID, +> criticality BOOLEAN DEFAULT FALSE, +> controlValue OCTET STRING OPTIONAL } + +-} +data Control = Control + { _Control'controlType :: LDAPOID + , _Control'criticality :: BOOLEAN_DEFAULT 'False + , _Control'controlValue :: Maybe OCTET_STRING + } deriving (Generic,Show,Eq) + +instance NFData Control + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 Control +instance ASN1Constructed Control +#endif + +{- | Object identifier () + +> LDAPOID ::= OCTET STRING -- Constrained to +> -- [RFC4512] + +-} +type LDAPOID = OID + +---------------------------------------------------------------------------- + +{- | Bind Request () + +> 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 + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 BindRequest where asn1defTag _ = Application 0 +instance ASN1Constructed BindRequest +#endif + +---------------------------------------------------------------------------- + +{- | 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 + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 AuthenticationChoice where + asn1decode = gasn1decodeChoice + asn1encode = gasn1encodeChoice +#endif + +{- | 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 + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 SaslCredentials +instance ASN1Constructed SaslCredentials +#endif + +---------------------------------------------------------------------------- + +{- | Bind Response () + +> BindResponse ::= [APPLICATION 1] SEQUENCE { +> COMPONENTS OF LDAPResult, +> serverSaslCreds [7] OCTET STRING OPTIONAL } + +-} + +data BindResponse = BindResponse + { _BindResponse'LDAPResult :: COMPONENTS_OF LDAPResult + , _BindResponse'serverSaslCreds :: Maybe ('CONTEXTUAL 7 `IMPLICIT` OCTET_STRING) + } deriving (Generic,Show,Eq) + +instance NFData BindResponse + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 BindResponse where asn1defTag _ = Application 1 +instance ASN1Constructed BindResponse +#endif + +---------------------------------------------------------------------------- + +{- | Unbind Operation () + +> UnbindRequest ::= [APPLICATION 2] NULL + +-} +type UnbindRequest = ('APPLICATION 2 `IMPLICIT` NULL) + +---------------------------------------------------------------------------- + +{- | Search Request () + +> 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 :: ENUMERATED Scope + , _SearchRequest'derefAliases :: ENUMERATED 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 +> -- in Section 4.5.1.8 + +-} +type AttributeSelection = [LDAPString] + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 SearchRequest where asn1defTag _ = Application 3 +instance ASN1Constructed SearchRequest +#endif + +-- | See 'SearchRequest' () +data Scope + = Scope'baseObject + | Scope'singleLevel + | Scope'wholeSubtree + deriving (Generic,Bounded,Enum,Show,Eq) + +instance NFData Scope where rnf = rwhnf +instance Enumerated Scope + +-- | See 'SearchRequest' () +data DerefAliases + = DerefAliases'neverDerefAliases + | DerefAliases'derefInSearching + | DerefAliases'derefFindingBaseObj + | DerefAliases'derefAlways + deriving (Generic,Bounded,Enum,Show,Eq) + +instance NFData DerefAliases where rnf = rwhnf +instance Enumerated DerefAliases + +{- | Search Filter () + +> 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, +> ... } + +See also "LDAPv3.StringRepr" for converting 'Filter' to and from the /String Representation of Search Filters/ (). + +-} +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 + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 Filter where + asn1decode = gasn1decodeChoice + asn1encode = gasn1encodeChoice +#endif + +{- Attribute Descriptions () + +> AttributeDescription ::= LDAPString +> -- Constrained to +> -- [RFC4512] + +@attributedescription@'s syntax is defined in ABNF () notation as + +> attributedescription = attributetype options +> attributetype = oid +> options = *( SEMI option ) +> option = 1*keychar +> oid = descr / numericoid +> descr = keystring +> numericoid = number 1*( DOT number ) +> keystring = leadkeychar *keychar +> leadkeychar = ALPHA +> ALPHA = %x41-5A / %x61-7A ; "A"-"Z" / "a"-"z" +> keychar = ALPHA / DIGIT / HYPHEN +> number = DIGIT / ( LDIGIT 1*DIGIT ) +> DIGIT = %x30 / LDIGIT ; "0"-"9" +> LDIGIT = %x31-39 ; "1"-"9" +> HYPHEN = %x2D ; hyphen ("-") + +See also for the definition of @attributedescription@. + +-} +-- type AttributeDescription = LDAPString + +{- | Attribute Value () + +> AttributeValue ::= OCTET STRING + +-} +type AttributeValue = OCTET_STRING + +{- | Attribute Value Assertion () + +> 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 + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 AttributeValueAssertion +instance ASN1Constructed AttributeValueAssertion +#endif + +{- | Substring 'Filter' () + +> 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 (CHOICE Substring) + } deriving (Generic,Show,Eq) + +instance NFData SubstringFilter + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 SubstringFilter +instance ASN1Constructed SubstringFilter +#endif + +-- | 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 + +{- | /Extensible Match/ 'SearchRequest' 'Filter' () + +> MatchingRuleAssertion ::= SEQUENCE { +> matchingRule [1] MatchingRuleId OPTIONAL, +> type [2] AttributeDescription OPTIONAL, +> matchValue [3] AssertionValue, +> dnAttributes [4] BOOLEAN DEFAULT FALSE } + +__NOTE__: The LDAPv3 specification imposes the additional invariant: + +/If the @matchingRule@ field is absent, the @type@ field MUST be present/ + +-} +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 :: ('CONTEXTUAL 4 `IMPLICIT` BOOLEAN_DEFAULT 'False) + } deriving (Generic,Show,Eq) + +instance NFData MatchingRuleAssertion + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 MatchingRuleAssertion +instance ASN1Constructed MatchingRuleAssertion +#endif + +---------------------------------------------------------------------------- + +{- | Search Result Continuation Reference () + +> SearchResultReference ::= [APPLICATION 19] SEQUENCE +> SIZE (1..MAX) OF uri URI + +-} + +newtype SearchResultReference = SearchResultReference ('APPLICATION 19 `IMPLICIT` NonEmpty URI) + deriving (Generic,NFData,Show,Eq) + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 SearchResultReference where + asn1defTag _ = Application 19 -- not used + asn1decode = SearchResultReference <$> asn1decode + asn1encode (SearchResultReference v) = asn1encode v +#endif + +---------------------------------------------------------------------------- + +{- | Search Result Entry () + +> SearchResultEntry ::= [APPLICATION 4] SEQUENCE { +> objectName LDAPDN, +> attributes PartialAttributeList } + +-} +data SearchResultEntry = SearchResultEntry + { _SearchResultEntry'objectName :: LDAPDN + , _SearchResultEntry'attributes :: PartialAttributeList + } deriving (Generic,Show,Eq) + +instance NFData SearchResultEntry + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 SearchResultEntry where asn1defTag _ = Application 4 +instance ASN1Constructed SearchResultEntry +#endif + +{- | See 'SearchResultEntry' + +> PartialAttributeList ::= SEQUENCE OF +> partialAttribute PartialAttribute + +-} +type PartialAttributeList = [PartialAttribute] + +{- | Partial Attribute () + +> 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 + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 PartialAttribute +instance ASN1Constructed PartialAttribute +#endif + + +{- | Attribute () + +> 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 + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 Attribute +instance ASN1Constructed Attribute +#endif + +---------------------------------------------------------------------------- + +{- | Search Result Done () + +> SearchResultDone ::= [APPLICATION 5] LDAPResult + +-} +type SearchResultDone = ('APPLICATION 5 `IMPLICIT` LDAPResult) + +---------------------------------------------------------------------------- + +{- | Result Message () + +> 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 :: ENUMERATED ResultCode + , _LDAPResult'matchedDN :: LDAPDN + , _LDAPResult'diagnosticMessage :: LDAPString + , _LDAPResult'referral :: Maybe ('CONTEXTUAL 3 `IMPLICIT` Referral) + } deriving (Generic,Show,Eq) + +instance NFData LDAPResult + +{- | Referral result code () + +> 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 + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 LDAPResult +instance ASN1Constructed LDAPResult +#endif + +{- | String Type () + +> LDAPString ::= OCTET STRING -- UTF-8 encoded, +> -- [ISO10646] characters + +-} +type LDAPString = ShortText + +{- | Distinguished Name () + +> LDAPDN ::= LDAPString -- Constrained to +> -- [RFC4514] + +-} +type LDAPDN = LDAPString + +{- | Relative Distinguished Name () + +> RelativeLDAPDN ::= LDAPString -- Constrained to +> -- [RFC4514] + +-} +type RelativeLDAPDN = LDAPString + +{- | Modify Operation () + +> 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 + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 ModifyRequest where asn1defTag _ = Application 6 +instance ASN1Constructed ModifyRequest +#endif + +-- | See 'ModifyRequest' +data Change = Change + { _Change'operation :: ENUMERATED Operation + , _Change'modification :: PartialAttribute + } deriving (Generic,Show,Eq) + +instance NFData Change + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 Change +instance ASN1Constructed Change +#endif + +-- | 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 Enumerated Operation + + +{- | Modify Response () + +> ModifyResponse ::= [APPLICATION 7] LDAPResult + +-} +type ModifyResponse = ('APPLICATION 7 `IMPLICIT` LDAPResult) + +{- | Add Operation () + +> AddRequest ::= [APPLICATION 8] SEQUENCE { +> entry LDAPDN, +> attributes AttributeList } + +-} +data AddRequest = AddRequest + { _AddRequest'entry :: LDAPDN + , _AddRequest'attributes :: AttributeList + } deriving (Generic,Show,Eq) + +instance NFData AddRequest + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 AddRequest where asn1defTag _ = Application 8 +instance ASN1Constructed AddRequest +#endif + +{- | Attribute List + +> AttributeList ::= SEQUENCE OF attribute Attribute + +-} +type AttributeList = [Attribute] + +{- | Add Response () + +> AddResponse ::= [APPLICATION 9] LDAPResult + +-} +type AddResponse = ('APPLICATION 9 `IMPLICIT` LDAPResult) + + +{- | Delete Operation () + +> DelRequest ::= [APPLICATION 10] LDAPDN + +-} +type DelRequest = ('APPLICATION 10 `IMPLICIT` LDAPDN) + +{- | Delete Response () + +> DelResponse ::= [APPLICATION 11] LDAPResult + +-} +type DelResponse = ('APPLICATION 11 `IMPLICIT` LDAPResult) + +{- | Modify DN Operation () + +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 + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 ModifyDNRequest where asn1defTag _ = Application 12 +instance ASN1Constructed ModifyDNRequest +#endif + + +{- | Modify DN Response () + +> ModifyDNResponse ::= [APPLICATION 13] LDAPResult + +-} +type ModifyDNResponse = ('APPLICATION 13 `IMPLICIT` LDAPResult) + + +{- | Compare Operation () + +> CompareRequest ::= [APPLICATION 14] SEQUENCE { +> entry LDAPDN, +> ava AttributeValueAssertion } + +-} +data CompareRequest = CompareRequest + { _CompareRequest'entry :: LDAPDN + , _CompareRequest'ava :: AttributeValueAssertion + } deriving (Generic,Show,Eq) + +instance NFData CompareRequest + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 CompareRequest where asn1defTag _ = Application 14 +instance ASN1Constructed CompareRequest +#endif + +{- | Compare Response () + +> CompareResponse ::= [APPLICATION 15] LDAPResult + +-} +type CompareResponse = ('APPLICATION 15 `IMPLICIT` LDAPResult) + + +{- | Abandon Operation () + +> AbandonRequest ::= [APPLICATION 16] MessageID + +-} +type AbandonRequest = ('APPLICATION 16 `IMPLICIT` MessageID) + +{- | Extended Request () + +> 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 + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 ExtendedRequest where asn1defTag _ = Application 23 +instance ASN1Constructed ExtendedRequest +#endif + +{- | Extended Response () + +> ExtendedResponse ::= [APPLICATION 24] SEQUENCE { +> COMPONENTS OF LDAPResult, +> responseName [10] LDAPOID OPTIONAL, +> responseValue [11] OCTET STRING OPTIONAL } + +-} +data ExtendedResponse = ExtendedResponse + { _ExtendedResponse'LDAPResult :: COMPONENTS_OF LDAPResult + , _ExtendedResponse'responseName :: Maybe ('CONTEXTUAL 10 `IMPLICIT` LDAPOID) + , _ExtendedResponse'responseValue :: Maybe ('CONTEXTUAL 11 `IMPLICIT` OCTET_STRING) + } deriving (Generic,Show,Eq) + +instance NFData ExtendedResponse + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 ExtendedResponse where asn1defTag _ = Application 24 +instance ASN1Constructed ExtendedResponse +#endif + +{- | Intermediate Response () + +> 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 + +#if defined(HS_LDAPv3_ANNOTATED) +instance ASN1 IntermediateResponse where asn1defTag _ = Application 25 +instance ASN1Constructed IntermediateResponse +#endif diff --git a/src/LDAPv3/Message/Annotated.hs b/src/LDAPv3/Message/Annotated.hs new file mode 100644 --- /dev/null +++ b/src/LDAPv3/Message/Annotated.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE CPP #-} +#define HS_LDAPv3_ANNOTATED 1 +#include "../Message.hs" diff --git a/src/LDAPv3/Message/Types.hs b/src/LDAPv3/Message/Types.hs new file mode 100644 --- /dev/null +++ b/src/LDAPv3/Message/Types.hs @@ -0,0 +1,62 @@ +-- Copyright (c) 2019 Herbert Valerio Riedel +-- +-- This file is free software: you may copy, redistribute and/or modify it +-- under the terms of the GNU General Public License as published by the +-- Free Software Foundation, either version 2 of the License, or (at your +-- option) any later version. +-- +-- This file is distributed in the hope that it will be useful, but +-- WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see `LICENSE`). If not, see +-- . + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module LDAPv3.Message.Types where + +import Common +import Data.ASN1 (ASN1) +import Data.Int.Subtypes + +{- | LDAPv3 protocol ASN.1 constant as per + +> maxInt INTEGER ::= 2147483647 -- (2^^31 - 1) + +-} +type MaxInt = 2147483647 + +{- | Message ID () + +> MessageID ::= INTEGER (0 .. maxInt) + +-} +newtype MessageID = MessageID (UInt 0 MaxInt Int32) + deriving (Generic,NFData,Ord,Bounded,Show,Eq,ASN1) + +instance Newtype MessageID (UInt 0 MaxInt Int32) + +-- | @since 0.1.0 +instance Enum MessageID where + succ (MessageID i) = MessageID (i+1) + pred (MessageID i) = MessageID (i-1) + + fromEnum (MessageID i) = intCast (fromUInt i) + + toEnum i + | i < 0 = throw Underflow + | i > 0x7fffffff = throw Overflow + | otherwise = MessageID (toUInt' (fromIntegral i)) + + enumFrom x = enumFromTo x maxBound + enumFromThen x y = enumFromThenTo x y bound + where + bound | y >= x = maxBound + | otherwise = minBound diff --git a/src/LDAPv3/ResultCode.hs b/src/LDAPv3/ResultCode.hs --- a/src/LDAPv3/ResultCode.hs +++ b/src/LDAPv3/ResultCode.hs @@ -19,7 +19,7 @@ module LDAPv3.ResultCode (ResultCode(..)) where import Common -import Data.ASN1 +import Data.ASN1 (Enumerated (..)) import qualified Data.Map.Strict as Map import Data.Tuple (swap) @@ -131,10 +131,6 @@ 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 + fromEnumerated = Map.findWithDefault impossible `flip` fromEnumeratedMap diff --git a/src/LDAPv3/SearchFilter.hs b/src/LDAPv3/SearchFilter.hs new file mode 100644 --- /dev/null +++ b/src/LDAPv3/SearchFilter.hs @@ -0,0 +1,259 @@ +-- Copyright (c) 2019 Herbert Valerio Riedel +-- +-- This file is free software: you may copy, redistribute and/or modify it +-- under the terms of the GNU General Public License as published by the +-- Free Software Foundation, either version 2 of the License, or (at your +-- option) any later version. +-- +-- This file is distributed in the hope that it will be useful, but +-- WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see `LICENSE`). If not, see +-- . + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | String representation of LDAPv3 search 'Filter's as defined by . +-- +-- @since 0.1.0 +module LDAPv3.SearchFilter + ( r'Filter + , p'Filter + ) where + +import Common hiding (many, option, some, (<|>)) +import LDAPv3.AttributeDescription +import LDAPv3.Message + +import qualified Data.ByteString as BS +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Text.Lazy.Builder as B +import Data.Text.Lazy.Builder.Int (hexadecimal) + +import Text.Parsec as P + +-- -- | Render LDAPv3 search 'Filter's into text representation +-- renderFilter :: Filter -> Text +-- renderFilter = T.toStrict . B.toLazyText . r'Filter + +r'Filter :: Filter -> Builder +r'Filter = r'filter + where + r'filter :: Filter -> Builder + r'filter f0 = singleton '(' <> f' <> singleton ')' + where + f' = case f0 of + Filter'and (SET1 fs) -> singleton '&' <> sconcat (fmap r'filter fs) + Filter'or (SET1 fs) -> singleton '|' <> sconcat (fmap r'filter fs) + Filter'not f -> singleton '!' <> r'filter f + Filter'equalityMatch ava -> r'simple (singleton '=') ava + Filter'greaterOrEqual ava -> r'simple ">=" ava + Filter'lessOrEqual ava -> r'simple "<=" ava + Filter'approxMatch ava -> r'simple "~=" ava + Filter'present attr -> r'AttributeDescription attr <> "=*" + Filter'substrings sub -> r'substring sub + Filter'extensibleMatch ext -> r'extensible ext + + + r'simple :: Builder -> AttributeValueAssertion -> Builder + r'simple filtertype (AttributeValueAssertion attr assertionvalue) + = r'AttributeDescription attr <> filtertype <> r'assertionvalue assertionvalue + + r'substring :: SubstringFilter -> Builder + r'substring (SubstringFilter attr (s1:|ss)) + = r'AttributeDescription attr <> singleton '=' <> + (case s1 of + Substring'initial x -> r'assertionvalue x <> go ss + _ -> go (s1:ss) + ) + where + go (Substring'initial _ : _) = error "renderFilter: invalid SubstringFilter (misplaced 'initial')" + go (Substring'final _ : _ : _) = error "renderFilter: invalid SubstringFilter (misplaced 'final')" + go [Substring'final x] = singleton '*' <> r'assertionvalue x + go (Substring'any x : xs) = singleton '*' <> r'assertionvalue x <> go xs + go [] = singleton '*' + + r'assertionvalue :: AssertionValue -> Builder + r'assertionvalue bs + | Right t <- T.decodeUtf8' bs = fromText (T.concatMap escT t) + | otherwise = mconcat (map escB $ BS.unpack bs) + where + escT :: Char -> Text + escT = \case + -- minimal escaping + '\x00' -> "\\00" + '\x28' -> "\\28" + '\x29' -> "\\29" + '\x2a' -> "\\2a" + '\x5c' -> "\\5c" + c -> T.singleton c + + escB :: Word8 -> Builder + escB = \case + 0x00 -> "\\00" + 0x28 -> "\\28" + 0x29 -> "\\29" + 0x2a -> "\\2a" + 0x5c -> "\\5c" + w | w < 0x80 -> singleton (toEnum (intCast w)) + | otherwise -> singleton '\\' <> hexadecimal w + + r'extensible :: MatchingRuleAssertion -> Builder + r'extensible (MatchingRuleAssertion matchingrule attr assertionvalue dnattrs) + | isNothing matchingrule, isNothing attr = "renderFilter: invalid MatchingRuleAssertion (matchingRule field absent and type field not present)" + | otherwise = mconcat [ maybe mempty r'AttributeDescription attr + , if dnattrs then ":dn" else mempty + , maybe mempty (\mrid -> singleton ':' <> r'MatchingRuleId mrid) matchingrule + , ":=", r'assertionvalue assertionvalue + ] + +-- TODO +-- -- | Parse string representation of a LDAPv3 search 'Filter's +-- parseFilter :: Text -> Either ParseError Filter +-- parseFilter = parse (parsecFilter <* eof) "" + +-- | 'Parsec' parser for parsing string representations of a LDAPv3 search 'Filter's +p'Filter :: Stream s Identity Char => Parsec s () Filter +p'Filter = p'filter + where + -- filter = LPAREN filtercomp RPAREN + p'filter = char '(' *> p'filtercomp <* char ')' + + -- filtercomp = and / or / not / item + -- and = AMPERSAND filterlist + -- or = VERTBAR filterlist + -- not = EXCLAMATION filter + p'filtercomp + = choice [ Filter'and <$> (char '&' *> p'filterlist) + , Filter'or <$> (char '|' *> p'filterlist) + , Filter'not <$> (char '!' *> p'filter) + , p'item + ] + + -- filterlist = 1*filter + p'filterlist = SET1 <$> some p'filter + + -- item = simple / present / substring / extensible + -- simple = attr filtertype assertionvalue + -- filtertype = equal / approx / greaterorequal / lessorequal + -- equal = EQUALS + -- approx = TILDE EQUALS + -- greaterorequal = RANGLE EQUALS + -- lessorequal = LANGLE EQUALS + -- present = attr EQUALS ASTERISK + -- substring = attr EQUALS [initial] any [final] + -- initial = assertionvalue + -- any = ASTERISK *(assertionvalue ASTERISK) + -- final = assertionvalue + -- attr = attributedescription + -- ; The attributedescription rule is defined in + -- ; Section 2.5 of [RFC4512]. + p'item = p'itemWithAttr <|> p'extensible Nothing + + p'itemWithAttr = do + attr <- p'AttributeDescription "attributedescription" + + choice [ Filter'approxMatch . AttributeValueAssertion attr <$> (string "~=" *> p'assertionvalue) + , Filter'greaterOrEqual . AttributeValueAssertion attr <$> (string ">=" *> p'assertionvalue) + , Filter'lessOrEqual . AttributeValueAssertion attr <$> (string "<=" *> p'assertionvalue) + -- attr EQUALS ([initial] any [final] / assertionvalue) + , char '=' *> (p'substringOrPresent attr + <|> (Filter'equalityMatch . AttributeValueAssertion attr <$> p'assertionvalue)) + -- attr [dnattrs] [matchingrule] COLON EQUALS assertionvalue + , p'extensible (Just attr) + ] + + -- extensible = ( attr [dnattrs] + -- [matchingrule] COLON EQUALS assertionvalue ) + -- / ( [dnattrs] + -- matchingrule COLON EQUALS assertionvalue ) + p'extensible mattr = do + let _MatchingRuleAssertion'type = mattr + _MatchingRuleAssertion'dnAttributes <- option False (True <$ p'dnattrs) + _MatchingRuleAssertion'matchingRule <- case mattr of + Nothing -> Just <$> p'matchingrule + Just _ -> option Nothing (Just <$> try p'matchingrule) + void (string ":=") + _MatchingRuleAssertion'matchValue <- p'assertionvalue + pure (Filter'extensibleMatch (MatchingRuleAssertion {..})) + + -- dnattrs = COLON "dn" + p'dnattrs = try (char ':' *> (char 'd' <|> char 'D') *> (char 'n' <|> char 'N') *> pure ()) + + -- matchingrule = COLON oid + p'matchingrule = char ':' *> p'MatchingRuleId + + -- [assertionvalue] *(assertionvalue ASTERISK) [assertionvalue] + p'substringOrPresent attr = try $ do + let bs2lst x = if BS.null x then [] else [x] + + initial <- bs2lst <$> p'assertionvalue + -- TODO: are empty fragments allowed? i.e. f** or ** ; according to ABNF it seems so + anys <- char '*' *> many (try (p'assertionvalue <* char '*')) + final <- bs2lst <$> p'assertionvalue + + pure $! case (Substring'initial <$> initial) ++ + (Substring'any <$> anys) ++ + (Substring'final <$> final) of + [] -> Filter'present attr + x:xs -> Filter'substrings (SubstringFilter attr (x:|xs)) + + -- assertionvalue = valueencoding + -- ; The rule is used to encode an + -- ; from Section 4.1.6 of [RFC4511]. + -- valueencoding = 0*(normal / escaped) + -- normal = UTF1SUBSET / UTFMB + -- escaped = ESC HEX HEX + -- UTF1SUBSET = %x01-27 / %x2B-5B / %x5D-7F + -- ; UTF1SUBSET excludes 0x00 (NUL), LPAREN, + -- ; RPAREN, ASTERISK, and ESC. + p'assertionvalue = deescape <$> many ((Right <$> satisfy (`notElem` ['\x00','(',')','*','\\'])) <|> Left <$> p'escaped) + + p'escaped = char '\\' *> ((\hi lo -> hi*16 + lo) <$> p'HEX <*> p'HEX) + + p'HEX = (fromIntegral :: Int -> Word8) . go . fromEnum <$> hexDigit + where + go n + | n `inside` (0x30,0x39) = n - 0x30 + | n `inside` (0x61,0x66) = n - (0x61 - 10) + | n `inside` (0x41,0x46) = n - (0x41 - 10) + | otherwise = undefined + + +---------------------------------------------------------------------------- + +deescape :: [Either Word8 Char] -> OCTET_STRING +deescape = mconcat . map go . groupEither + where + go (Left (x:|xs)) = BS.pack (x:xs) + go (Right (c:|cs)) = T.encodeUtf8 (T.pack (c:cs)) + +groupEither :: [Either l r] -> [Either (NonEmpty l) (NonEmpty r)] +groupEither = \case + [] -> [] + Left l : rest -> goLeft (l:|[]) rest + Right r : rest -> goRight (r:|[]) rest + where + goLeft acc [] = Left (NE.reverse acc) : [] + goLeft acc (Left l : rest) = goLeft (l<|acc) rest + goLeft acc (Right r : rest) = Left (NE.reverse acc) : goRight (r:|[]) rest + + goRight acc [] = Right (NE.reverse acc) : [] + goRight acc (Left l : rest) = Right (NE.reverse acc) : goLeft (l:|[]) rest + goRight acc (Right r : rest) = goRight (r<|acc) rest + +{-# INLINE some #-} +some :: Stream s m t => ParsecT s u m a -> ParsecT s u m (NonEmpty a) +some p = do + xs0 <- many1 p + case xs0 of + [] -> fail "some': the impossible just happened" + (x:xs) -> pure (x:|xs) diff --git a/src/LDAPv3/StringRepr.hs b/src/LDAPv3/StringRepr.hs new file mode 100644 --- /dev/null +++ b/src/LDAPv3/StringRepr.hs @@ -0,0 +1,112 @@ +-- Copyright (c) 2019 Herbert Valerio Riedel +-- +-- This file is free software: you may copy, redistribute and/or modify it +-- under the terms of the GNU General Public License as published by the +-- Free Software Foundation, either version 2 of the License, or (at your +-- option) any later version. +-- +-- This file is distributed in the hope that it will be useful, but +-- WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see `LICENSE`). If not, see +-- . + +{-# LANGUAGE FlexibleContexts #-} + +-- | String representation of LDAPv3 search 'Filter's as defined by . +-- +-- @since 0.1.0 +module LDAPv3.StringRepr + ( StringRepr ( asParsec + , asBuilder + , renderShortText + ) + , renderText + , renderString + , parseShortText + , parseText + , parseString + ) where + +import Common hiding (Option, many, option, some, (<|>)) + +import qualified Data.Text.Lazy as T (toStrict) +import Data.Text.Lazy.Builder as B +import qualified Data.Text.Short as TS +import Text.Parsec as P + +import LDAPv3.AttributeDescription +import LDAPv3.Message (Filter) +import LDAPv3.SearchFilter + +-- | Convert to and from string representations as defined by . +-- +-- @since 0.1.0 +class StringRepr a where + asParsec :: Stream s Identity Char => Parsec s () a + + asBuilder :: a -> Builder + asBuilder = fromText . TS.toText . renderShortText + + renderShortText :: a -> ShortText + renderShortText = TS.fromText . T.toStrict . B.toLazyText . asBuilder + + {-# MINIMAL asParsec, (renderShortText | asBuilder) #-} + +-- | Convenience 'StringRepr' operation for rendering as 'Text' +-- +-- @since 0.1.0 +renderText :: StringRepr a => a -> Text +renderText = TS.toText . renderShortText + +-- | Convenience 'StringRepr' operation for rendering as plain-old 'String' +-- +-- @since 0.1.0 +renderString :: StringRepr a => a -> String +renderString = TS.toString . renderShortText + +-- | Convenience 'StringRepr' operation for parsing from 'Text' +-- +-- @since 0.1.0 +parseText :: StringRepr a => Text -> Maybe a +parseText = either (const Nothing) Just . parse (asParsec <* eof) "" + +-- | Convenience 'StringRepr' operation for parsing from 'ShortText' +-- +-- @since 0.1.0 +parseShortText :: StringRepr a => ShortText -> Maybe a +parseShortText = either (const Nothing) Just . parse (asParsec <* eof) "" . TS.toString + +-- | Convenience 'StringRepr' operation for parsing from plain-old 'String' +-- +-- @since 0.1.0 +parseString :: StringRepr a => String -> Maybe a +parseString = either (const Nothing) Just . parse (asParsec <* eof) "" + +instance StringRepr AttributeDescription where + asParsec = p'AttributeDescription + renderShortText = ts'AttributeDescription + +instance StringRepr Option where + asParsec = p'Option + renderShortText = ts'Option + +instance StringRepr OID where + asBuilder = r'OID + renderShortText = ts'OID + asParsec = p'OID + +instance StringRepr KeyString where + asParsec = p'KeyString + renderShortText = ts'KeyString + +instance StringRepr MatchingRuleId where + asParsec = p'MatchingRuleId + renderShortText = ts'MatchingRuleId + +instance StringRepr Filter where + asBuilder = r'Filter + asParsec = p'Filter diff --git a/test/Arbitrary.hs b/test/Arbitrary.hs --- a/test/Arbitrary.hs +++ b/test/Arbitrary.hs @@ -16,15 +16,21 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Arbitrary () where -import LDAPv3 +import LDAPv3.Message +import qualified Data.ByteString as BS +import qualified Data.Char as C import Data.Coerce (coerce) import Data.Int +import Data.List.NonEmpty (NonEmpty (..)) +import Data.String (fromString) import qualified Data.Text.Short as TS import Test.QuickCheck.Instances () import Test.Tasty.QuickCheck @@ -33,13 +39,13 @@ 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 (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 (EXPLICIT tag x) where +-- arbitrary = EXPLICIT <$> arbitrary +-- shrink (EXPLICIT x) = coerce (shrink x) instance Arbitrary x => Arbitrary (SET x) where arbitrary = SET <$> arbitrary @@ -72,11 +78,11 @@ arbitrary = LDAPMessage <$> arbitrary <*> arbitrary <*> arbitrary shrink = genericShrink -instance Arbitrary BOOLEAN_DEFAULT_FALSE where - arbitrary = pure BOOL_TRUE +-- instance Arbitrary (BOOLEAN_DEFAULT b) where +-- arbitrary = BOOLEAN <$> arbitrary instance Arbitrary Control where - arbitrary = Control <$> arbitrary <*> oneof [pure Nothing, pure (Just BOOL_TRUE)] <*> arbitrary + arbitrary = Control <$> arbitrary <*> arbitrary <*> arbitrary shrink = genericShrink instance Arbitrary LDAPResult where @@ -85,8 +91,8 @@ instance Arbitrary ProtocolOp where arbitrary = frequency - [ (2, ProtocolOp'bindRequest <$> arbitrary) - , (2, ProtocolOp'bindResponse <$> arbitrary) + [ (2, ProtocolOp'bindRequest <$> arbitrary) + , (2, ProtocolOp'bindResponse <$> arbitrary) , (1, ProtocolOp'unbindRequest <$> arbitrary) , (5, ProtocolOp'searchRequest <$> arbitrary) , (1, ProtocolOp'searchResDone <$> arbitrary) @@ -163,19 +169,42 @@ shrink = genericShrink instance Arbitrary SubstringFilter where - arbitrary = SubstringFilter <$> arbitrary <*> arbitrary + arbitrary = SubstringFilter <$> arbitrary <*> sub'arbitrary + where + sub'arbitrary = do + initial <- oneof [ ((:[]) . Substring'initial) <$> nonEmptyBS, pure [] ] + final <- oneof [ ((:[]) . Substring'final) <$> nonEmptyBS, pure [] ] + anys <- case (initial,final) of + ([],[]) -> listOf nonEmptyBS `suchThat` (not . null) + _ -> listOf nonEmptyBS + + case (initial ++ map Substring'any anys ++ final) of + [] -> error "the impossible just happened" + (x:xs) -> pure (x:|xs) + + nonEmptyBS = arbitrary `suchThat` (not . BS.null) shrink = genericShrink instance Arbitrary MatchingRuleAssertion where - arbitrary = MatchingRuleAssertion <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + arbitrary = do + _MatchingRuleAssertion'matchingRule <- arbitrary + -- /If the @matchingRule@ field is absent, the @type@ field MUST be present/ + _MatchingRuleAssertion'type <- case _MatchingRuleAssertion'matchingRule of + Just _ -> arbitrary + Nothing -> Just <$> arbitrary + _MatchingRuleAssertion'matchValue <- arbitrary + _MatchingRuleAssertion'dnAttributes <- arbitrary + pure MatchingRuleAssertion {..} shrink = genericShrink instance Arbitrary Substring where - arbitrary = oneof [ Substring'initial <$> arbitrary - , Substring'any <$> arbitrary - , Substring'final <$> arbitrary + arbitrary = oneof [ Substring'initial <$> nonEmptyBS + , Substring'any <$> nonEmptyBS + , Substring'final <$> nonEmptyBS ] - shrink = genericShrink + where + nonEmptyBS = arbitrary `suchThat` (not . BS.null) + -- shrink = genericShrink instance Arbitrary SearchResultEntry where arbitrary = SearchResultEntry <$> arbitrary <*> arbitrary @@ -232,3 +261,28 @@ instance Arbitrary IntermediateResponse where arbitrary = IntermediateResponse <$> arbitrary <*> arbitrary shrink = genericShrink + + + +instance Arbitrary AttributeDescription where + arbitrary = AttributeDescription <$> arbitrary <*> arbitrary + shrink = genericShrink + +instance Arbitrary MatchingRuleId where + arbitrary = MatchingRuleId <$> (arbitrary `suchThat` (/= Left "dn")) -- avoid grammar ambiguity + shrink = genericShrink + +instance Arbitrary KeyString where + arbitrary = fromString <$> ((:) <$> a'leadkeychar <*> listOf a'keychar) + +instance Arbitrary Option where + arbitrary = fromString <$> (listOf a'keychar `suchThat` (not . null)) + +a'keychar :: Gen Char +a'keychar = choose ('-', 'z') `suchThat` (\c -> C.isAsciiUpper c || C.isAsciiLower c || C.isDigit c || c == '-') + +a'leadkeychar :: Gen Char +a'leadkeychar = choose ('A', 'z') `suchThat` C.isLetter + +instance Arbitrary OID where + arbitrary = OID <$> arbitrary diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -20,9 +20,11 @@ module Main (main) where -import LDAPv3 +import LDAPv3.Message +import LDAPv3.StringRepr import qualified Codec.Base16 as B16 +import Control.DeepSeq import Data.Binary as Bin import qualified Data.ByteString.Lazy as BSL import Data.Char (isSpace) @@ -39,18 +41,29 @@ main :: IO () main = defaultMain tests -tests, qcProps, unitTests :: TestTree -tests = testGroup "Tests" [unitTests, qcProps] +tests, qcPropsRFC4511, qcPropsRFC4515, unitTestsRFC4511, unitTestsRFC4515 :: TestTree ----------------------------------------------------------------------------- +tests = testGroup "Tests" [unitTestsRFC4515, unitTestsRFC4511, qcPropsRFC4515, qcPropsRFC4511] -qcProps = testGroup "Properties" +---------------------------------------------------------------------------------------------------- + +qcPropsRFC4515 = testGroup "Properties (RFC4515)" + [ QC.testProperty "parse/render Filter roundtrip" $ + \f -> parseShortText (renderShortText (f :: Filter)) === Just f + ] + +---------------------------------------------------------------------------------------------------- + +qcPropsRFC4511 = testGroup "Properties (RFC4511)" [ QC.testProperty "MessageID round-trip" $ \msgid -> let msg = LDAPMessage msgid (ProtocolOp'bindRequest (BindRequest 3 "" (AuthenticationChoice'simple ""))) Nothing in decode (encode msg) == msg + , QC.testProperty "encode" $ + \(msg :: LDAPMessage) -> rnf (encode msg) === () + , QC.testProperty "decode . encode == id @LDAPMessage" $ \(msg :: LDAPMessage) -> (decode . encode) msg === msg @@ -64,28 +77,24 @@ \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 + 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" +unitTestsRFC4511 = testGroup "Golden tests (RFC4511)" [ testGroup tlabel [ testCase "encode" $ Bin.encode ref_msg @?= ref_bin , testCase "decode" $ Bin.decode ref_bin @?= ref_msg @@ -129,13 +138,11 @@ { bindRequest'version = 3 , bindRequest'name = "" , bindRequest'authentication = AuthenticationChoice'sasl - ( IMPLICIT ( SaslCredentials { _SaslCredentials'mechanism = "DIGEST-MD5" , _SaslCredentials'credentials = Nothing } ) - ) } ) , _LDAPMessage'controls = Nothing @@ -209,7 +216,7 @@ , _SearchRequest'sizeLimit = 0 , _SearchRequest'timeLimit = 0 , _SearchRequest'typesOnly = False - , _SearchRequest'filter = Filter'present ( IMPLICIT "objectclass" ) + , _SearchRequest'filter = Filter'present "objectclass" , _SearchRequest'attributes = [] } ) @@ -230,17 +237,13 @@ , _SearchRequest'timeLimit = 0 , _SearchRequest'typesOnly = False , _SearchRequest'filter = Filter'not - ( EXPLICIT ( Filter'equalityMatch - ( IMPLICIT ( AttributeValueAssertion { _AttributeValueAssertion'attributeDesc = "objectClass" , _AttributeValueAssertion'assertionValue = "person" } ) - ) ) - ) , _SearchRequest'attributes = [] } ) @@ -261,51 +264,41 @@ , _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 ) + , _MatchingRuleAssertion'type = Just "ou" + , _MatchingRuleAssertion'matchValue = "ResearchAndDevelopment" + , _MatchingRuleAssertion'dnAttributes = True } ) - ) :| + :| [ Filter'extensibleMatch - ( IMPLICIT ( MatchingRuleAssertion { _MatchingRuleAssertion'matchingRule = Nothing - , _MatchingRuleAssertion'type = Just ( IMPLICIT "ou" ) - , _MatchingRuleAssertion'matchValue = IMPLICIT "HumanResources" - , _MatchingRuleAssertion'dnAttributes = Just ( IMPLICIT BOOL_TRUE ) + , _MatchingRuleAssertion'type = Just "ou" + , _MatchingRuleAssertion'matchValue = "HumanResources" + , _MatchingRuleAssertion'dnAttributes = True } ) - ) ] ) ) - ) ) - ) :| + :| [ Filter'equalityMatch - ( IMPLICIT ( AttributeValueAssertion { _AttributeValueAssertion'attributeDesc = "objectClass" , _AttributeValueAssertion'assertionValue = "person" } ) - ) ] ) ) - ) , _SearchRequest'attributes = [] } ) @@ -327,7 +320,6 @@ , _SearchRequest'timeLimit = 0 , _SearchRequest'typesOnly = False , _SearchRequest'filter = Filter'substrings - ( IMPLICIT ( SubstringFilter { _SubstringFilter'type = "cn" , _SubstringFilter'substrings = @@ -337,7 +329,6 @@ ] } ) - ) , _SearchRequest'attributes = [] } ) @@ -412,7 +403,6 @@ , 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 = "" @@ -420,7 +410,6 @@ , _LDAPResult'referral = Nothing } ) - ) , _LDAPMessage'controls = Nothing } ) @@ -429,7 +418,6 @@ , 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 = "" @@ -437,7 +425,6 @@ , _LDAPResult'referral = Nothing } ) - ) , _LDAPMessage'controls = Nothing } ) @@ -445,7 +432,7 @@ , ( "unbindRequest" , hex"30 05 02 01 03 42 00" , LDAPMessage { _LDAPMessage'messageID = MessageID 3 - , _LDAPMessage'protocolOp = ProtocolOp'unbindRequest (IMPLICIT ()) + , _LDAPMessage'protocolOp = ProtocolOp'unbindRequest () , _LDAPMessage'controls = Nothing } ) @@ -453,3 +440,246 @@ ] ] + +---------------------------------------------------------------------------------------------------- + +unitTestsRFC4515 = testGroup "Golden tests (RFC4515)" + [ testGroup tlabel $ + [ testCase "parseFilter" $ parseShortText ref_string @?= Just ref_filter + , testCase "renderFilter" $ renderShortText ref_filter @?= ref_string2 + ] ++ + [ testCase "parseFilter #2" $ parseShortText ref_string2 @?= Just ref_filter + | ref_string2 /= ref_string + ] + + | (tlabel,(ref_string,ref_string2),ref_filter) <- + [ + ( "RFC4515 example #1" + , dup"(cn=Babs Jensen)" + , Filter'equalityMatch + ( AttributeValueAssertion + { _AttributeValueAssertion'attributeDesc = "cn" + , _AttributeValueAssertion'assertionValue = "Babs Jensen" + } + ) + ) + , + ( "RFC4515 example #2" + , dup"(!(cn=Tim Howes))" + , Filter'not + ( Filter'equalityMatch + ( AttributeValueAssertion + { _AttributeValueAssertion'attributeDesc = "cn" + , _AttributeValueAssertion'assertionValue = "Tim Howes" + } + ) + ) + ) + , + ( "RFC4515 example #3" + , dup"(&(objectClass=Person)(|(sn=Jensen)(cn=Babs J*)))" + , Filter'and + ( SET1 + ( Filter'equalityMatch + ( AttributeValueAssertion + { _AttributeValueAssertion'attributeDesc = "objectClass" + , _AttributeValueAssertion'assertionValue = "Person" + } + ) :| + [ Filter'or + ( SET1 + ( Filter'equalityMatch + ( AttributeValueAssertion + { _AttributeValueAssertion'attributeDesc = "sn" + , _AttributeValueAssertion'assertionValue = "Jensen" + } + ) :| + [ Filter'substrings + ( SubstringFilter + { _SubstringFilter'type = "cn" + , _SubstringFilter'substrings = Substring'initial "Babs J" :| [] + } + ) + ] + ) + ) + ] + ) + ) + ) + , + ( "RFC4515 example #4" + , dup"(o=univ*of*mich*)" + , Filter'substrings + ( SubstringFilter + { _SubstringFilter'type = "o" + , _SubstringFilter'substrings = Substring'initial "univ" :| + [ Substring'any "of" + , Substring'any "mich" + ] + } + ) + ) + , + ( "RFC4515 example #5" + , dup"(seeAlso=)" + , Filter'equalityMatch + ( AttributeValueAssertion + { _AttributeValueAssertion'attributeDesc = "seeAlso" + , _AttributeValueAssertion'assertionValue = "" + } + ) + ) + , + ( "RFC4515 example #6" + , dup"(cn:caseExactMatch:=Fred Flintstone)" + , Filter'extensibleMatch + ( MatchingRuleAssertion + { _MatchingRuleAssertion'matchingRule = Just "caseExactMatch" + , _MatchingRuleAssertion'type = Just "cn" + , _MatchingRuleAssertion'matchValue = "Fred Flintstone" + , _MatchingRuleAssertion'dnAttributes = False + } + ) + ) + , + ( "RFC4515 example #7" + , dup"(cn:=Betty Rubble)" + , Filter'extensibleMatch + ( MatchingRuleAssertion + { _MatchingRuleAssertion'matchingRule = Nothing + , _MatchingRuleAssertion'type = Just "cn" + , _MatchingRuleAssertion'matchValue = "Betty Rubble" + , _MatchingRuleAssertion'dnAttributes = False + } + ) + ) + , + ( "RFC4515 example #8" + , dup"(sn:dn:2.4.6.8.10:=Barney Rubble)" + , Filter'extensibleMatch + ( MatchingRuleAssertion + { _MatchingRuleAssertion'matchingRule = Just "2.4.6.8.10" + , _MatchingRuleAssertion'type = Just "sn" + , _MatchingRuleAssertion'matchValue = "Barney Rubble" + , _MatchingRuleAssertion'dnAttributes = True + } + ) + ) + , + ( "RFC4515 example #9" + , dup"(o:dn:=Ace Industry)" + , Filter'extensibleMatch + ( MatchingRuleAssertion + { _MatchingRuleAssertion'matchingRule = Nothing + , _MatchingRuleAssertion'type = Just "o" + , _MatchingRuleAssertion'matchValue = "Ace Industry" + , _MatchingRuleAssertion'dnAttributes = True + } + ) + ) + , + ( "RFC4515 example #10" + , dup"(:1.2.3:=Wilma Flintstone)" + , Filter'extensibleMatch + ( MatchingRuleAssertion + { _MatchingRuleAssertion'matchingRule = Just "1.2.3" + , _MatchingRuleAssertion'type = Nothing + , _MatchingRuleAssertion'matchValue = "Wilma Flintstone" + , _MatchingRuleAssertion'dnAttributes = False + } + ) + ) + , + ( "RFC4515 example #11" + , ( "(:DN:2.4.6.8.10:=Dino)" + , "(:dn:2.4.6.8.10:=Dino)" + ) + , Filter'extensibleMatch + ( MatchingRuleAssertion + { _MatchingRuleAssertion'matchingRule = Just "2.4.6.8.10" + , _MatchingRuleAssertion'type = Nothing + , _MatchingRuleAssertion'matchValue = "Dino" + , _MatchingRuleAssertion'dnAttributes = True + } + ) + ) + , + ( "RFC4515 example #12" + , dup"(o=Parens R Us \\28for all your parenthetical needs\\29)" + , Filter'equalityMatch + ( AttributeValueAssertion + { _AttributeValueAssertion'attributeDesc = "o" + , _AttributeValueAssertion'assertionValue = "Parens R Us (for all your parenthetical needs)" + } + ) + ) + , + ( "RFC4515 example #13" + , ( "(cn=*\\2A*)" + , "(cn=*\\2a*)" + ) + , Filter'substrings + ( SubstringFilter + { _SubstringFilter'type = "cn" + , _SubstringFilter'substrings = Substring'any "*" :| [] + } + ) + ) + , + ( "RFC4515 example #14" + , dup"(filename=C:\\5cMyFile)" + , Filter'equalityMatch + ( AttributeValueAssertion + { _AttributeValueAssertion'attributeDesc = "filename" + , _AttributeValueAssertion'assertionValue = "C:\\MyFile" + } + ) + ) + , + ( "RFC4515 example #15" + , ( "(bin=\\00\\00\\00\\04)" + , "(bin=\\00\\00\\00\x04)" + ) + , Filter'equalityMatch + ( AttributeValueAssertion + { _AttributeValueAssertion'attributeDesc = "bin" + , _AttributeValueAssertion'assertionValue = "\x0\x0\x0\x4" + } + ) + ) + , + ( "RFC4515 example #16" + , ( "(sn=Lu\\c4\\8di\\c4\\87)" + , "(sn=Lučić)" + ) + , Filter'equalityMatch + ( AttributeValueAssertion + { _AttributeValueAssertion'attributeDesc = "sn" + , _AttributeValueAssertion'assertionValue = "LuÄ\x8diÄ\x87" -- Lučić + } + ) + ) + , + ( "RFC4515 example #17" + , ( "(1.3.6.1.4.1.1466.0=\\04\\02\\48\\69)" + , "(1.3.6.1.4.1.1466.0=\x04\x02Hi)" + ) + , Filter'equalityMatch + ( AttributeValueAssertion + { _AttributeValueAssertion'attributeDesc = "1.3.6.1.4.1.1466.0" + , _AttributeValueAssertion'assertionValue = "\x04\x02\x48\x69" -- ASN.1 encoding + } + ) + ) + ] + ] + +---------------------------------------------------------------------------------------------------- +-- local helper + +dup :: x -> (x,x) +dup x = (x,x) + +hex :: TS.ShortText -> BSL.ByteString +hex = either error id . B16.decode . TS.toShortByteString . TS.filter (not . isSpace)