421 lines
11 KiB
Haskell
421 lines
11 KiB
Haskell
module Ldap.Asn1.ToAsn1
|
|
( ToAsn1(toAsn1)
|
|
) where
|
|
|
|
import Data.ASN1.Types (ASN1, ASN1Class, ASN1Tag, ASN1ConstructionType)
|
|
import qualified Data.ASN1.Types as Asn1
|
|
import Data.ByteString (ByteString)
|
|
import Data.Foldable (fold, foldMap)
|
|
import Data.List.NonEmpty (NonEmpty)
|
|
import Data.Maybe (maybe)
|
|
import Data.Monoid (Endo(Endo), (<>), mempty)
|
|
import qualified Data.Text.Encoding as Text
|
|
import Prelude (Integer, (.), fromIntegral)
|
|
|
|
import Ldap.Asn1.Type
|
|
|
|
|
|
class ToAsn1 a where
|
|
toAsn1 :: a -> Endo [ASN1]
|
|
|
|
{- |
|
|
@
|
|
LDAPMessage ::= SEQUENCE {
|
|
messageID MessageID,
|
|
protocolOp CHOICE {
|
|
bindRequest BindRequest,
|
|
bindResponse BindResponse,
|
|
unbindRequest UnbindRequest,
|
|
searchRequest SearchRequest,
|
|
searchResEntry SearchResultEntry,
|
|
searchResDone SearchResultDone,
|
|
searchResRef SearchResultReference,
|
|
addRequest AddRequest,
|
|
addResponse AddResponse,
|
|
... },
|
|
controls [0] Controls OPTIONAL }
|
|
@
|
|
-}
|
|
instance ToAsn1 op => ToAsn1 (LdapMessage op) where
|
|
toAsn1 (LdapMessage i op mc) =
|
|
sequence (toAsn1 i <> toAsn1 op <> maybe mempty (context 0 . toAsn1) mc)
|
|
|
|
{- |
|
|
@
|
|
MessageID ::= INTEGER (0 .. maxInt)
|
|
@
|
|
-}
|
|
instance ToAsn1 Id where
|
|
toAsn1 (Id i) = single (Asn1.IntVal (fromIntegral i))
|
|
|
|
{- |
|
|
@
|
|
LDAPString ::= OCTET STRING -- UTF-8 encoded
|
|
@
|
|
-}
|
|
instance ToAsn1 LdapString where
|
|
toAsn1 (LdapString s) = single (Asn1.OctetString (Text.encodeUtf8 s))
|
|
|
|
{- |
|
|
@
|
|
LDAPOID ::= OCTET STRING -- Constrained to \<numericoid\>
|
|
@
|
|
-}
|
|
instance ToAsn1 LdapOid where
|
|
toAsn1 (LdapOid s) = single (Asn1.OctetString s)
|
|
|
|
{- |
|
|
@
|
|
LDAPDN ::= LDAPString -- Constrained to \<distinguishedName\>
|
|
@
|
|
-}
|
|
instance ToAsn1 LdapDn where
|
|
toAsn1 (LdapDn s) = toAsn1 s
|
|
|
|
{- |
|
|
@
|
|
RelativeLDAPDN ::= LDAPString -- Constrained to \<name-component\>
|
|
@
|
|
-}
|
|
instance ToAsn1 RelativeLdapDn where
|
|
toAsn1 (RelativeLdapDn s) = toAsn1 s
|
|
|
|
{- |
|
|
@
|
|
AttributeDescription ::= LDAPString
|
|
@
|
|
-}
|
|
instance ToAsn1 AttributeDescription where
|
|
toAsn1 (AttributeDescription s) = toAsn1 s
|
|
|
|
{- |
|
|
@
|
|
AttributeValue ::= OCTET STRING
|
|
@
|
|
-}
|
|
instance ToAsn1 AttributeValue where
|
|
toAsn1 (AttributeValue s) = single (Asn1.OctetString s)
|
|
|
|
{- |
|
|
@
|
|
AttributeValueAssertion ::= SEQUENCE {
|
|
attributeDesc AttributeDescription,
|
|
assertionValue AssertionValue }
|
|
@
|
|
-}
|
|
instance ToAsn1 AttributeValueAssertion where
|
|
toAsn1 (AttributeValueAssertion d v) = toAsn1 d <> toAsn1 v
|
|
|
|
{- |
|
|
@
|
|
AssertionValue ::= OCTET STRING
|
|
@
|
|
-}
|
|
instance ToAsn1 AssertionValue where
|
|
toAsn1 (AssertionValue s) = single (Asn1.OctetString s)
|
|
|
|
|
|
{- |
|
|
@
|
|
PartialAttribute ::= SEQUENCE {
|
|
type AttributeDescription,
|
|
vals SET OF value AttributeValue }
|
|
@
|
|
-}
|
|
instance ToAsn1 PartialAttribute where
|
|
toAsn1 (PartialAttribute d xs) = sequence (toAsn1 d <> set (toAsn1 xs))
|
|
|
|
{- |
|
|
@
|
|
Attribute ::= PartialAttribute(WITH COMPONENTS {
|
|
...,
|
|
vals (SIZE(1..MAX))})
|
|
@
|
|
-}
|
|
instance ToAsn1 Attribute where
|
|
toAsn1 (Attribute d xs) = sequence (toAsn1 d <> set (toAsn1 xs))
|
|
|
|
{- |
|
|
@
|
|
MatchingRuleId ::= LDAPString
|
|
@
|
|
-}
|
|
instance ToAsn1 MatchingRuleId where
|
|
toAsn1 (MatchingRuleId s) = toAsn1 s
|
|
|
|
{- |
|
|
@
|
|
Controls ::= SEQUENCE OF control Control
|
|
@
|
|
-}
|
|
instance ToAsn1 Controls where
|
|
toAsn1 (Controls cs) = sequence (toAsn1 cs)
|
|
|
|
{- |
|
|
@
|
|
Control ::= SEQUENCE {
|
|
controlType LDAPOID,
|
|
criticality BOOLEAN DEFAULT FALSE,
|
|
controlValue OCTET STRING OPTIONAL }
|
|
@
|
|
-}
|
|
instance ToAsn1 Control where
|
|
toAsn1 (Control t c v) =
|
|
sequence (fold
|
|
[ toAsn1 t
|
|
, single (Asn1.Boolean c)
|
|
, maybe mempty (single . Asn1.OctetString) v
|
|
])
|
|
|
|
{- |
|
|
@
|
|
BindRequest ::= [APPLICATION 0] SEQUENCE {
|
|
version INTEGER (1 .. 127),
|
|
name LDAPDN,
|
|
authentication AuthenticationChoice }
|
|
@
|
|
|
|
@
|
|
UnbindRequest ::= [APPLICATION 2] NULL
|
|
@
|
|
|
|
@
|
|
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 }
|
|
@
|
|
|
|
@
|
|
ModifyRequest ::= [APPLICATION 6] SEQUENCE {
|
|
object LDAPDN,
|
|
changes SEQUENCE OF change SEQUENCE {
|
|
operation ENUMERATED {
|
|
add (0),
|
|
delete (1),
|
|
replace (2),
|
|
... },
|
|
modification PartialAttribute } }
|
|
@
|
|
|
|
@
|
|
AddRequest ::= [APPLICATION 8] SEQUENCE {
|
|
entry LDAPDN,
|
|
attributes AttributeList }
|
|
@
|
|
|
|
@
|
|
DelRequest ::= [APPLICATION 10] LDAPDN
|
|
@
|
|
|
|
@
|
|
ModifyDNRequest ::= [APPLICATION 12] SEQUENCE {
|
|
entry LDAPDN,
|
|
newrdn RelativeLDAPDN,
|
|
deleteoldrdn BOOLEAN,
|
|
newSuperior [0] LDAPDN OPTIONAL }
|
|
@
|
|
|
|
@
|
|
CompareRequest ::= [APPLICATION 14] SEQUENCE {
|
|
entry LDAPDN,
|
|
ava AttributeValueAssertion }
|
|
@
|
|
|
|
@
|
|
ExtendedRequest ::= [APPLICATION 23] SEQUENCE {
|
|
requestName [0] LDAPOID,
|
|
requestValue [1] OCTET STRING OPTIONAL }
|
|
@
|
|
-}
|
|
instance ToAsn1 ProtocolClientOp where
|
|
toAsn1 (BindRequest v n a) =
|
|
application 0 (single (Asn1.IntVal (fromIntegral v)) <> toAsn1 n <> toAsn1 a)
|
|
toAsn1 UnbindRequest =
|
|
other Asn1.Application 2 mempty
|
|
toAsn1 (SearchRequest bo s da sl tl to f a) =
|
|
application 3 (fold
|
|
[ toAsn1 bo
|
|
, enum s'
|
|
, enum da'
|
|
, single (Asn1.IntVal (fromIntegral sl))
|
|
, single (Asn1.IntVal (fromIntegral tl))
|
|
, single (Asn1.Boolean to)
|
|
, toAsn1 f
|
|
, toAsn1 a
|
|
])
|
|
where
|
|
s' = case s of
|
|
BaseObject -> 0
|
|
SingleLevel -> 1
|
|
WholeSubtree -> 2
|
|
da' = case da of
|
|
NeverDerefAliases -> 0
|
|
DerefInSearching -> 1
|
|
DerefFindingBaseObject -> 2
|
|
DerefAlways -> 3
|
|
toAsn1 (ModifyRequest dn xs) =
|
|
application 6 (fold
|
|
[ toAsn1 dn
|
|
, sequence (foldMap (\(op, pa) -> sequence (enum (case op of
|
|
Add -> 0
|
|
Delete -> 1
|
|
Replace -> 2) <> toAsn1 pa)) xs)
|
|
])
|
|
toAsn1 (AddRequest dn as) =
|
|
application 8 (toAsn1 dn <> toAsn1 as)
|
|
toAsn1 (DeleteRequest (LdapDn (LdapString dn))) =
|
|
other Asn1.Application 10 (Text.encodeUtf8 dn)
|
|
toAsn1 (ModifyDnRequest dn rdn del new) =
|
|
application 12 (fold
|
|
[ toAsn1 dn
|
|
, toAsn1 rdn
|
|
, single (Asn1.Boolean del)
|
|
, maybe mempty
|
|
(\(LdapDn (LdapString dn')) -> other Asn1.Context 0 (Text.encodeUtf8 dn'))
|
|
new
|
|
])
|
|
toAsn1 (CompareRequest dn av) =
|
|
application 14 (toAsn1 dn <> sequence (toAsn1 av))
|
|
toAsn1 (ExtendedRequest (LdapOid oid) mv) =
|
|
application 23 (fold
|
|
[ other Asn1.Context 0 oid
|
|
, maybe mempty (other Asn1.Context 1) mv
|
|
])
|
|
|
|
{- |
|
|
@
|
|
AuthenticationChoice ::= CHOICE {
|
|
simple [0] OCTET STRING,
|
|
... }
|
|
@
|
|
-}
|
|
instance ToAsn1 AuthenticationChoice where
|
|
toAsn1 (Simple s) = other Asn1.Context 0 s
|
|
|
|
{- |
|
|
@
|
|
AttributeSelection ::= SEQUENCE OF selector LDAPString
|
|
@
|
|
-}
|
|
instance ToAsn1 AttributeSelection where
|
|
toAsn1 (AttributeSelection as) = sequence (toAsn1 as)
|
|
|
|
{- |
|
|
@
|
|
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,
|
|
... }
|
|
@
|
|
-}
|
|
instance ToAsn1 Filter where
|
|
toAsn1 f = case f of
|
|
And xs -> context 0 (toAsn1 xs)
|
|
Or xs -> context 1 (toAsn1 xs)
|
|
Not x -> context 2 (toAsn1 x)
|
|
EqualityMatch x -> context 3 (toAsn1 x)
|
|
Substrings x -> context 4 (toAsn1 x)
|
|
GreaterOrEqual x -> context 5 (toAsn1 x)
|
|
LessOrEqual x -> context 6 (toAsn1 x)
|
|
Present (AttributeDescription (LdapString x))
|
|
-> other Asn1.Context 7 (Text.encodeUtf8 x)
|
|
ApproxMatch x -> context 8 (toAsn1 x)
|
|
ExtensibleMatch x -> context 9 (toAsn1 x)
|
|
|
|
{- |
|
|
@
|
|
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
|
|
}
|
|
@
|
|
-}
|
|
instance ToAsn1 SubstringFilter where
|
|
toAsn1 (SubstringFilter ad ss) =
|
|
toAsn1 ad <> sequence (foldMap (\s -> case s of
|
|
Initial (AssertionValue v) -> other Asn1.Context 0 v
|
|
Any (AssertionValue v) -> other Asn1.Context 1 v
|
|
Final (AssertionValue v) -> other Asn1.Context 2 v) ss)
|
|
|
|
{- |
|
|
@
|
|
MatchingRuleAssertion ::= SEQUENCE {
|
|
matchingRule [1] MatchingRuleId OPTIONAL,
|
|
type [2] AttributeDescription OPTIONAL,
|
|
matchValue [3] AssertionValue,
|
|
dnAttributes [4] BOOLEAN DEFAULT FALSE }
|
|
@
|
|
-}
|
|
instance ToAsn1 MatchingRuleAssertion where
|
|
toAsn1 (MatchingRuleAssertion mmr mad (AssertionValue av) _) = fold
|
|
[ maybe mempty f mmr
|
|
, maybe mempty g mad
|
|
, other Asn1.Context 3 av
|
|
]
|
|
where
|
|
f (MatchingRuleId (LdapString x)) = other Asn1.Context 1 (Text.encodeUtf8 x)
|
|
g (AttributeDescription (LdapString x)) = other Asn1.Context 2 (Text.encodeUtf8 x)
|
|
|
|
{- |
|
|
@
|
|
AttributeList ::= SEQUENCE OF attribute Attribute
|
|
@
|
|
-}
|
|
instance ToAsn1 AttributeList where
|
|
toAsn1 (AttributeList xs) = sequence (toAsn1 xs)
|
|
|
|
instance ToAsn1 a => ToAsn1 [a] where
|
|
toAsn1 = foldMap toAsn1
|
|
|
|
instance ToAsn1 a => ToAsn1 (NonEmpty a) where
|
|
toAsn1 = foldMap toAsn1
|
|
|
|
sequence :: Endo [ASN1] -> Endo [ASN1]
|
|
sequence = construction Asn1.Sequence
|
|
|
|
set :: Endo [ASN1] -> Endo [ASN1]
|
|
set = construction Asn1.Set
|
|
|
|
application :: ASN1Tag -> Endo [ASN1] -> Endo [ASN1]
|
|
application = construction . Asn1.Container Asn1.Application
|
|
|
|
context :: ASN1Tag -> Endo [ASN1] -> Endo [ASN1]
|
|
context = construction . Asn1.Container Asn1.Context
|
|
|
|
construction :: ASN1ConstructionType -> Endo [ASN1] -> Endo [ASN1]
|
|
construction t x = single (Asn1.Start t) <> x <> single (Asn1.End t)
|
|
|
|
other :: ASN1Class -> ASN1Tag -> ByteString -> Endo [ASN1]
|
|
other c t = single . Asn1.Other c t
|
|
|
|
enum :: Integer -> Endo [ASN1]
|
|
enum = single . Asn1.Enumerated
|
|
|
|
single :: a -> Endo [a]
|
|
single x = Endo (x :)
|