{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
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
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
'\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
]
p'Filter :: Stream s Identity Char => Parsec s () Filter
p'Filter = p'filter
where
p'filter = char '(' *> p'filtercomp <* char ')'
p'filtercomp
= choice [ Filter'and <$> (char '&' *> p'filterlist)
, Filter'or <$> (char '|' *> p'filterlist)
, Filter'not <$> (char '!' *> p'filter)
, p'item
]
p'filterlist = SET1 <$> some p'filter
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)
, char '=' *> (p'substringOrPresent attr
<|> (Filter'equalityMatch . AttributeValueAssertion attr <$> p'assertionvalue))
, p'extensible (Just attr)
]
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 {..}))
p'dnattrs = try (char ':' *> (char 'd' <|> char 'D') *> (char 'n' <|> char 'N') *> pure ())
p'matchingrule = char ':' *> p'MatchingRuleId
p'substringOrPresent attr = try $ do
let bs2lst x = if BS.null x then [] else [x]
initial <- bs2lst <$> p'assertionvalue
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))
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)