{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module      : Text.LDAP.Printer
-- Copyright   : 2014-2018 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
module Text.LDAP.Printer
       ( LdapPrinter, runLdapPrinter, LdapPutM

       , dn
       , component
       , attribute

       , ldifDN, ldifAttr

       , ldifAttrValue, ldifEncodeAttrValue

       , openLdapEntry, openLdapData
       ) where

import Prelude hiding (reverse)
import Data.Monoid (Endo (..))
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 ((<*))
import Control.Monad.Trans.Writer (Writer, tell, execWriter)
import Text.Printf (printf)
import Data.ByteArray.Encoding (Base (Base64), convertToBase)
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)


-- | Printer context type for LDAP data stream
type LdapPutM = Writer (Endo [ByteString])

-- | 'LdapPrinter' 'a' print type 'a' into context
type LdapPrinter a = a -> LdapPutM ()

-- | Run 'LdapPrinter'
runLdapPrinter :: LdapPrinter a -> a -> LB.ByteString
runLdapPrinter :: LdapPrinter a -> a -> ByteString
runLdapPrinter LdapPrinter a
p = [ByteString] -> ByteString
LB.fromChunks ([ByteString] -> ByteString)
-> (a -> [ByteString]) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Endo [ByteString] -> [ByteString] -> [ByteString]
forall a. Endo a -> a -> a
`appEndo` []) (Endo [ByteString] -> [ByteString])
-> (a -> Endo [ByteString]) -> a -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Writer (Endo [ByteString]) () -> Endo [ByteString]
forall w a. Writer w a -> w
execWriter (Writer (Endo [ByteString]) () -> Endo [ByteString])
-> LdapPrinter a -> a -> Endo [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LdapPrinter a
p

string :: LdapPrinter ByteString
string :: LdapPrinter ByteString
string =  Endo [ByteString] -> Writer (Endo [ByteString]) ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (Endo [ByteString] -> Writer (Endo [ByteString]) ())
-> (ByteString -> Endo [ByteString]) -> LdapPrinter ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ByteString] -> [ByteString]) -> Endo [ByteString]
forall a. (a -> a) -> Endo a
Endo (([ByteString] -> [ByteString]) -> Endo [ByteString])
-> (ByteString -> [ByteString] -> [ByteString])
-> ByteString
-> Endo [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:)

bslash :: Word8
bslash :: Word8
bslash =  Char -> Word8
ordW8 Char
'\\'

chrW8 :: Word8 -> Char
chrW8 :: Word8 -> Char
chrW8 =  Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

escapeValueChar :: Word8 -> [Word8]
escapeValueChar :: Word8 -> [Word8]
escapeValueChar Word8
w
  | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isAscii Char
c                       =  [Word8]
hex
  | Word8
w Word8 -> [Word8] -> Bool
forall a. Ord a => a -> [a] -> Bool
`elem'` [Word8]
echars                      =  [Word8
bslash, Word8
w]
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n'                =  [Word8]
hex
  | Char -> Bool
isPrint Char
c                             =  [Word8
w]
  | Bool
otherwise                             =  [Word8]
hex
  where c :: Char
c      = Word8 -> Char
chrW8 Word8
w
        echars :: [Word8]
echars = Word8
bslash Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Word8
Data.quotation Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
Data.specialChars
        hex :: [Word8]
hex    = (Word8
bslash Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
:) ([Word8] -> [Word8]) -> ([Char] -> [Word8]) -> [Char] -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Word8) -> [Char] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Word8
ordW8 ([Char] -> [Word8]) -> [Char] -> [Word8]
forall a b. (a -> b) -> a -> b
$ [Char] -> Word8 -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%02x" Word8
w

_testEscape :: IO ()
_testEscape :: IO ()
_testEscape =
  [Char] -> IO ()
putStr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [ (Word8, [Char]) -> [Char]
forall a. Show a => a -> [Char]
show (Word8
w, (Word8 -> Char) -> [Word8] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Char
chrW8 ([Word8] -> [Char]) -> [Word8] -> [Char]
forall a b. (a -> b) -> a -> b
$ Word8 -> [Word8]
escapeValueChar Word8
w) | Word8
w <- [Word8
0 .. Word8
255 ] ]

escapeValueBS :: ByteString -> ByteString
escapeValueBS :: ByteString -> ByteString
escapeValueBS =  [Word8] -> ByteString
BS.pack ([Word8] -> ByteString)
-> (ByteString -> [Word8]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> [Word8]) -> [Word8] -> [Word8]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Word8 -> [Word8]
escapeValueChar ([Word8] -> [Word8])
-> (ByteString -> [Word8]) -> ByteString -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack

char :: LdapPrinter Char
char :: LdapPrinter Char
char =  LdapPrinter ByteString
string LdapPrinter ByteString -> (Char -> ByteString) -> LdapPrinter Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ByteString
singleton

newline :: LdapPutM ()
newline :: Writer (Endo [ByteString]) ()
newline =  LdapPrinter Char
char Char
'\n'

-- DN
attrType :: LdapPrinter AttrType
attrType :: LdapPrinter AttrType
attrType =  LdapPrinter AttrType
d  where
  d :: LdapPrinter AttrType
d (AttrType ByteString
s)         =  LdapPrinter ByteString
string ByteString
s
  d (AttrOid (ByteString
x :| [ByteString]
xs))  =  do
    LdapPrinter ByteString
string ByteString
x
    LdapPrinter ByteString
-> [ByteString] -> Writer (Endo [ByteString]) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ByteString
x' ->  LdapPrinter Char
char Char
'.' Writer (Endo [ByteString]) ()
-> Writer (Endo [ByteString]) () -> Writer (Endo [ByteString]) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LdapPrinter ByteString
string ByteString
x') [ByteString]
xs

attrValue :: LdapPrinter AttrValue
attrValue :: LdapPrinter AttrValue
attrValue (AttrValue ByteString
s) =  LdapPrinter ByteString
string LdapPrinter ByteString
-> (ByteString -> ByteString) -> LdapPrinter ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
escapeValueBS LdapPrinter ByteString -> LdapPrinter ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
s

-- | Printer of attribute pair string in RDN.
attribute :: LdapPrinter Attribute
attribute :: LdapPrinter Attribute
attribute (AttrType
t, AttrValue
v) =  do
  LdapPrinter AttrType
attrType  AttrType
t
  LdapPrinter Char
char Char
'='
  LdapPrinter AttrValue
attrValue AttrValue
v

-- | Printer of RDN string.
component :: LdapPrinter Component
component :: LdapPrinter Component
component =  LdapPrinter Component
d  where
  d :: LdapPrinter Component
d (S Attribute
a)          =  LdapPrinter Attribute
attribute Attribute
a
  d (L (Attribute
a :| [Attribute]
as))  =  do
    LdapPrinter Attribute
attribute Attribute
a
    LdapPrinter Attribute
-> [Attribute] -> Writer (Endo [ByteString]) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Attribute
a' -> LdapPrinter Char
char Char
'+' Writer (Endo [ByteString]) ()
-> Writer (Endo [ByteString]) () -> Writer (Endo [ByteString]) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LdapPrinter Attribute
attribute Attribute
a') [Attribute]
as

-- | Printer of DN string.
dn :: LdapPrinter DN
dn :: LdapPrinter DN
dn =  (Component, [Component]) -> Writer (Endo [ByteString]) ()
forall (t :: * -> *).
Foldable t =>
(Component, t Component) -> Writer (Endo [ByteString]) ()
d ((Component, [Component]) -> Writer (Endo [ByteString]) ())
-> (DN -> (Component, [Component])) -> LdapPrinter DN
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DN -> (Component, [Component])
unconsDN where
  d :: (Component, t Component) -> Writer (Endo [ByteString]) ()
d (Component
c, t Component
cs)  =  do
    LdapPrinter Component
component Component
c
    LdapPrinter Component
-> t Component -> Writer (Endo [ByteString]) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Component
c' -> LdapPrinter Char
char Char
',' Writer (Endo [ByteString]) ()
-> Writer (Endo [ByteString]) () -> Writer (Endo [ByteString]) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LdapPrinter Component
component Component
c') t Component
cs


-- LDIF

-- | Printer of LDIF DN line.
ldifDN :: LdapPrinter DN
ldifDN :: LdapPrinter DN
ldifDN DN
x = do
  LdapPrinter ByteString
string ByteString
"dn: "
  LdapPrinter DN
dn DN
x

-- | Printer of LDIF attribute value already encoded.
--   Available printer combinator to pass 'ldifAttr' or 'openLdapEntry', etc ...
ldifAttrValue :: LdapPrinter LdifAttrValue
ldifAttrValue :: LdapPrinter LdifAttrValue
ldifAttrValue = LdapPrinter LdifAttrValue
d  where
  d :: LdapPrinter LdifAttrValue
d (LAttrValRaw ByteString
s)    = do
    LdapPrinter Char
char Char
' '
    LdapPrinter ByteString
string ByteString
s
  d (LAttrValBase64 ByteString
s) = do
    LdapPrinter ByteString
string ByteString
": "
    LdapPrinter ByteString
string ByteString
s

ldifToSafeAttrValue :: AttrValue -> LdifAttrValue
ldifToSafeAttrValue :: AttrValue -> LdifAttrValue
ldifToSafeAttrValue (AttrValue ByteString
s) = do
  case Parser ByteString -> ByteString -> Either [Char] ByteString
forall a. Parser a -> ByteString -> Either [Char] a
parseOnly (Parser ByteString
ldifSafeString Parser ByteString -> Parser ByteString () -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
endOfInput) (ByteString -> Either [Char] ByteString)
-> ByteString -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
s of
    Right ByteString
_    ->  ByteString -> LdifAttrValue
LAttrValRaw ByteString
s
    Left  [Char]
_    ->  ByteString -> LdifAttrValue
LAttrValBase64 (ByteString -> LdifAttrValue) -> ByteString -> LdifAttrValue
forall a b. (a -> b) -> a -> b
$ Base -> ByteString -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64 ByteString
s

-- | Printer of LDIF attribute value with encode not safe string.
--   Available printer combinator to pass 'ldifAttr' or 'openLdapEntry', etc ...
ldifEncodeAttrValue :: LdapPrinter AttrValue
ldifEncodeAttrValue :: LdapPrinter AttrValue
ldifEncodeAttrValue =  LdapPrinter LdifAttrValue
ldifAttrValue LdapPrinter LdifAttrValue
-> (AttrValue -> LdifAttrValue) -> LdapPrinter AttrValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrValue -> LdifAttrValue
ldifToSafeAttrValue

-- | Printer of LDIF attribute pair line.
--   Use with 'ldifAttrValue' or 'ldifEncodeAttrValue' printer, like @ldifAttr ldifEncodeAttrValue@.
ldifAttr :: LdapPrinter v -> LdapPrinter (AttrType, v)
ldifAttr :: LdapPrinter v -> LdapPrinter (AttrType, v)
ldifAttr LdapPrinter v
vp (AttrType
a, v
v) = do
  LdapPrinter AttrType
attrType AttrType
a
  LdapPrinter Char
char Char
':'
  LdapPrinter v
vp v
v

-- | OpenLDAP data-stream block printer.
--   Use with 'ldifAttrValue' or 'ldifEncodeAttrValue' printer, like @openLdapEntry ldifEncodeAttrValue@.
openLdapEntry :: LdapPrinter v -> LdapPrinter (DN, [(AttrType, v)])
openLdapEntry :: LdapPrinter v -> LdapPrinter (DN, [(AttrType, v)])
openLdapEntry LdapPrinter v
vp (DN
x, [(AttrType, v)]
as) = do
  LdapPrinter DN
ldifDN DN
x
  Writer (Endo [ByteString]) ()
newline
  ((AttrType, v) -> Writer (Endo [ByteString]) ())
-> [(AttrType, v)] -> Writer (Endo [ByteString]) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Writer (Endo [ByteString]) ()
-> Writer (Endo [ByteString]) () -> Writer (Endo [ByteString]) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Writer (Endo [ByteString]) ()
newline) (Writer (Endo [ByteString]) () -> Writer (Endo [ByteString]) ())
-> ((AttrType, v) -> Writer (Endo [ByteString]) ())
-> (AttrType, v)
-> Writer (Endo [ByteString]) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LdapPrinter v -> (AttrType, v) -> Writer (Endo [ByteString]) ()
forall v. LdapPrinter v -> LdapPrinter (AttrType, v)
ldifAttr LdapPrinter v
vp) [(AttrType, v)]
as

-- | OpenLDAP data-stream block list printer.
--   Use with 'ldifAttrValue' or 'ldifEncodeAttrValue' printer, like @openLdapData ldifEncodeAttrValue@.
openLdapData :: LdapPrinter v -> LdapPrinter [(DN, [(AttrType, v)])]
openLdapData :: LdapPrinter v -> LdapPrinter [(DN, [(AttrType, v)])]
openLdapData LdapPrinter v
vp = ((DN, [(AttrType, v)]) -> Writer (Endo [ByteString]) ())
-> LdapPrinter [(DN, [(AttrType, v)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Writer (Endo [ByteString]) ()
-> Writer (Endo [ByteString]) () -> Writer (Endo [ByteString]) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Writer (Endo [ByteString]) ()
newline) (Writer (Endo [ByteString]) () -> Writer (Endo [ByteString]) ())
-> ((DN, [(AttrType, v)]) -> Writer (Endo [ByteString]) ())
-> (DN, [(AttrType, v)])
-> Writer (Endo [ByteString]) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LdapPrinter v
-> (DN, [(AttrType, v)]) -> Writer (Endo [ByteString]) ()
forall v. LdapPrinter v -> LdapPrinter (DN, [(AttrType, v)])
openLdapEntry LdapPrinter v
vp)