-- 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)