module Text.LDAP.Printer
( LdapPrinter, runLdapPrinter, LdapPutM
, dn
, component
, attribute
, ldifDN, ldifAttr
, ldifAttrValue, ldifEncodeAttrValue
, openLdapEntry, openLdapData
) where
import Prelude hiding (reverse)
import Data.DList (DList, toList)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Char (chr, isAscii, isPrint)
import Data.Word (Word8)
import qualified Data.ByteString as BS
import Data.ByteString.Char8 (ByteString, singleton)
import qualified Data.ByteString.Lazy as LB
import Control.Applicative (pure, (<*))
import Control.Monad.Trans.Writer (Writer, tell, execWriter)
import Text.Printf (printf)
import qualified Data.ByteString.Base64 as Base64
import Data.Attoparsec.ByteString (parseOnly, endOfInput)
import Text.LDAP.Data
(AttrType (..), AttrValue (..), Attribute,
Component (..), DN, unconsDN,
LdifAttrValue (..),
elem', ordW8)
import qualified Text.LDAP.Data as Data
import Text.LDAP.InternalParser (ldifSafeString)
type LdapPutM = Writer (DList ByteString)
type LdapPrinter a = a -> LdapPutM ()
runLdapPrinter :: LdapPrinter a -> a -> LB.ByteString
runLdapPrinter p = LB.fromChunks . toList . execWriter . p
string :: LdapPrinter ByteString
string = tell . pure
bslash :: Word8
bslash = ordW8 '\\'
chrW8 :: Word8 -> Char
chrW8 = chr . fromIntegral
escapeValueChar :: Word8 -> [Word8]
escapeValueChar w
| not $ isAscii c = hex
| w `elem'` echars = [bslash, w]
| c == '\r' || c == '\n' = hex
| isPrint c = [w]
| otherwise = hex
where c = chrW8 w
echars = bslash : Data.quotation : Data.specialChars
hex = (bslash :) . map ordW8 $ printf "%02x" w
_testEscape :: IO ()
_testEscape =
putStr $ unlines [ show (w, map chrW8 $ escapeValueChar w) | w <- [0 .. 255 ] ]
escapeValueBS :: ByteString -> ByteString
escapeValueBS = BS.pack . concatMap escapeValueChar . BS.unpack
char :: LdapPrinter Char
char = string . singleton
newline :: LdapPutM ()
newline = char '\n'
attrType :: LdapPrinter AttrType
attrType = d where
d (AttrType s) = string s
d (AttrOid (x :| xs)) = do
string x
mapM_ (\x' -> char '.' >> string x') xs
attrValue :: LdapPrinter AttrValue
attrValue (AttrValue s) = string . escapeValueBS $ s
attribute :: LdapPrinter Attribute
attribute (t, v) = do
attrType t
char '='
attrValue v
component :: LdapPrinter Component
component = d where
d (S a) = attribute a
d (L (a :| as)) = do
attribute a
mapM_ (\a' -> char '+' >> attribute a') as
dn :: LdapPrinter DN
dn = d . unconsDN where
d (c, cs) = do
component c
mapM_ (\c' -> char ',' >> component c') cs
ldifDN :: LdapPrinter DN
ldifDN x = do
string "dn: "
dn x
ldifAttrValue :: LdapPrinter LdifAttrValue
ldifAttrValue = d where
d (LAttrValRaw s) = do
char ' '
string s
d (LAttrValBase64 s) = do
string ": "
string s
ldifToSafeAttrValue :: AttrValue -> LdifAttrValue
ldifToSafeAttrValue (AttrValue s) = do
case parseOnly (ldifSafeString <* endOfInput) $ s of
Right _ -> LAttrValRaw s
Left _ -> LAttrValBase64 $ Base64.encode s
ldifEncodeAttrValue :: LdapPrinter AttrValue
ldifEncodeAttrValue = ldifAttrValue . ldifToSafeAttrValue
ldifAttr :: LdapPrinter v -> LdapPrinter (AttrType, v)
ldifAttr vp (a, v) = do
attrType a
char ':'
vp v
openLdapEntry :: LdapPrinter v -> LdapPrinter (DN, [(AttrType, v)])
openLdapEntry vp (x, as) = do
ldifDN x
newline
mapM_ ((>> newline) . ldifAttr vp) as
openLdapData :: LdapPrinter v -> LdapPrinter [(DN, [(AttrType, v)])]
openLdapData vp = mapM_ ((>> newline) . openLdapEntry vp)