-- 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 , p'DescrOrOID ) where import Common hiding (Option, many, option, some, (<|>)) import Data.ASN1 import LDAPv3.StringRepr.Class 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 StringRepr AttributeDescription where asParsec = p'AttributeDescription renderShortText = 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 StringRepr Option where asParsec = p'Option renderShortText = ts'Option 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 instance StringRepr OID where asBuilder = r'OID renderShortText = ts'OID asParsec = 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 {- | 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 instance StringRepr KeyString where asParsec = p'KeyString renderShortText = ts'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 instance StringRepr MatchingRuleId where asParsec = p'MatchingRuleId renderShortText = ts'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)