-- Copyright (c) 2020  Herbert Valerio Riedel <hvr@gnu.org>
--
--  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
--  <https://www.gnu.org/licenses/old-licenses/gpl-2.0.html>.

{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}

-- internal module
module LDAPv3.DistinguishedName
  ( DistinguishedName(..)
  , rfc4514coreAttributes
  ) where

import           Common                      hiding (Option, many, option, some, (<|>))
import           LDAPv3.AttributeDescription
import           LDAPv3.Message              (OCTET_STRING)
import           LDAPv3.StringRepr.Class

import qualified Data.ByteString             as BS
import           Data.Char                   (chr)
import           Data.List                   as L
import           Data.Text.Lazy.Builder      as B
import qualified Data.Text.Lazy.Builder.Int  as B
import qualified Data.Text.Short             as TS

import           Text.Parsec                 as P


-- | Haskell representation of the table below as defined in <https://tools.ietf.org/search/rfc4514#section-3 RFC4514 Section 3>.
--
-- +--------+-----------------------------------------------+
-- | String | X.500 AttributeType                           |
-- +========+===============================================+
-- | CN     | commonName (2.5.4.3)                          |
-- +--------+-----------------------------------------------+
-- | L      | localityName (2.5.4.7)                        |
-- +--------+-----------------------------------------------+
-- | ST     | stateOrProvinceName (2.5.4.8)                 |
-- +--------+-----------------------------------------------+
-- | O      | organizationName (2.5.4.10)                   |
-- +--------+-----------------------------------------------+
-- | OU     | organizationalUnitName (2.5.4.11)             |
-- +--------+-----------------------------------------------+
-- | C      | countryName (2.5.4.6)                         |
-- +--------+-----------------------------------------------+
-- | STREET | streetAddress (2.5.4.9)                       |
-- +--------+-----------------------------------------------+
-- | DC     | domainComponent (0.9.2342.19200300.100.1.25)  |
-- +--------+-----------------------------------------------+
-- | UID    | userId (0.9.2342.19200300.100.1.1)            |
-- +--------+-----------------------------------------------+
--
-- @since 0.1.1
rfc4514coreAttributes :: [(KeyString,OID)]
rfc4514coreAttributes =
    [ ("CN"     {- commonName             -} , oid [2,5,4,3]                    )
    , ("L"      {- localityName           -} , oid [2,5,4,7]                    )
    , ("ST"     {- stateOrProvinceName    -} , oid [2,5,4,8]                    )
    , ("O"      {- organizationName       -} , oid [2,5,4,10]                   )
    , ("OU"     {- organizationalUnitName -} , oid [2,5,4,11]                   )
    , ("C"      {- countryName            -} , oid [2,5,4,6]                    )
    , ("STREET" {- streetAddress          -} , oid [2,5,4,9]                    )
    , ("DC"     {- domainComponent        -} , oid [0,9,2342,19200300,100,1,25] )
    , ("UID"    {- userId                 -} , oid [0,9,2342,19200300,100,1,1]  )
    ]
  where
    oid = \(n:ns) -> OID (n :| ns)

-- | Decoded non-normalizing string representation of @DistinguishedName@
--
-- > DistinguishedName ::= RDNSequence
-- >
-- > RDNSequence ::= SEQUENCE OF RelativeDistinguishedName
-- >
-- > RelativeDistinguishedName ::= SET SIZE (1..MAX) OF
-- >     AttributeTypeAndValue
-- >
-- > AttributeTypeAndValue ::= SEQUENCE {
-- >     type  AttributeType,
-- >     value AttributeValue }
--
-- Raw ASN.1 Hex-encoded @AttributeValue@s are represented as 'OCTET_STRING' (which implies they MUST not be a size-0 'OCTET_STRING') whereas 'ShortText' is used for textually encoded (possibly containing escaped characters) values.
--
-- As defined in RFC4514, the RDNSequence is serialized in reverse order.
--
-- @since 0.1.1
newtype DistinguishedName = DistinguishedName [NonEmpty (Either KeyString OID,Either OCTET_STRING ShortText)]
  deriving (Eq,Show)

instance StringRepr DistinguishedName where
  asBuilder = r'DistinguishedName
  asParsec  = p'DistinguishedName


r'DistinguishedName :: DistinguishedName -> Builder
r'DistinguishedName (DistinguishedName rdns) = case L.reverse rdns of
    []   -> mempty
    r:rs -> sepby r'rdn ',' (r :| rs)
  where
    r'rdn = sepby r'atav '+'

    r'atav (k,v) = either asBuilder asBuilder k <> B.singleton '=' <> either r'hexval r'textval v

    r'hexval = mconcat . (B.singleton '#' :) . map r'word8hex . BS.unpack

    r'word8hex x
      | x < 0x10 = B.singleton '0' <> B.hexadecimal x
      | otherwise = B.hexadecimal x

    r'textval t
      | needEscape t = B.fromString $ goEsc $ TS.unpack t
      | otherwise = b'ShortText t

    goEsc []         = ""
    goEsc (' ':rest) = '\\':' ':goEsc1 rest
    goEsc ('#':rest) = '\\':'#':goEsc1 rest
    goEsc rest       = goEsc1 rest

    goEsc1 []  = ""
    goEsc1 " " = "\\ "
    goEsc1 (c:rest)
      | c == '\0'  = '\\':'0':'0':goEsc1 rest
      | needEsc1 c = '\\':c:goEsc1 rest
      | otherwise  = c:goEsc1 rest

    needEscape t
      | TS.null t = False
      | Just c <- TS.indexMaybe t 0
      , c == '#' || c == ' ' = True
      | Just c <- TS.indexEndMaybe t 0
      , c == ' ' = True
      | TS.any (\c -> needEsc1 c || c == '\0') t = True
      | otherwise = False

    needEsc1 '"'  = True
    needEsc1 '+'  = True
    needEsc1 ','  = True
    needEsc1 ';'  = True
    needEsc1 '<'  = True
    needEsc1 '>'  = True
    needEsc1 '\\' = True
    needEsc1 _    = False

    sepby rend c (x :| xs) = rend x <> go xs
      where
        go []     = mempty
        go (y:ys) = B.singleton c <> rend y <> go ys

p'DistinguishedName :: Stream s Identity Char => Parsec s () DistinguishedName
p'DistinguishedName = DistinguishedName . L.reverse <$> p'distinguishedName -- optional
  where
    -- distinguishedName = [ relativeDistinguishedName *( COMMA relativeDistinguishedName ) ]
    p'distinguishedName = p'relativeDistinguishedName `sepBy` char ','

    -- relativeDistinguishedName = attributeTypeAndValue *( PLUS attributeTypeAndValue )
    p'relativeDistinguishedName = p'attributeTypeAndValue `sepBy1'` char '+'

    -- attributeTypeAndValue = attributeType EQUALS attributeValue
    -- attributeType = descr / numericoid
    -- attributeValue = string / hexstring

    p'attributeTypeAndValue = do
      ty <- p'DescrOrOID
      _ <- char '='
      va <- (Left <$> p'hexstring) <|> (Right <$> p'string)
      pure (ty,va)

    -- ; The following characters are to be escaped when they appear
    -- ; in the value to be encoded: ESC, one of <escaped>, leading
    -- ; SHARP or SPACE, trailing SPACE, and NULL.
    -- string = [ ( leadchar / pair ) [ *( stringchar / pair ) ( trailchar / pair ) ] ]
    p'string = do
      mc0 <- optionMaybe $ (C <$> satisfy isLeadchar) <|> p'pair
      case mc0 of
        Nothing -> pure mempty
        Just c0 -> do
          -- since the grammar above doesn't lend itself to be expressed directly with Parsec
          -- combinators, we defer the unescaped-trailing-space check to keep things simple...
          cs <- many ((C <$> satisfy isStringchar) <|> p'pair)
          case cs of
            []  -> pure ()
            _:_ -> when (last cs == C ' ') $ fail "trailing unescaped SPACE encountered in <string>"

          pure $ TS.fromString $ map unescape (c0:cs)

    -- leadchar = LUTF1 / UTFMB
    -- LUTF1 = %x01-1F / %x21 / %x24-2A / %x2D-3A / %x3D / %x3F-5B / %x5D-7F
    isLeadchar c = case c of
      '\x00' -> False
      '\x20' -> False -- ' '
      '\x22' -> False -- '"'
      '\x23' -> False -- '#'
      '\x2B' -> False -- '+'
      '\x2C' -> False -- ','
      '\x3B' -> False -- ';'
      '\x3C' -> False -- '<'
      '\x3E' -> False -- '>'
      '\x5C' -> False -- '\\'
      _      -> True

    -- trailchar  = TUTF1 / UTFMB
    -- TUTF1 = %x01-1F / %x21 / %x23-2A / %x2D-3A / %x3D / %x3F-5B / %x5D-7F

    -- stringchar = SUTF1 / UTFMB
    -- SUTF1 = %x01-21        / %x23-2A / %x2D-3A / %x3D / %x3F-5B / %x5D-7F
    isStringchar c = case c of
      '\x00' -> False
      '\x22' -> False -- '"'
      '\x2B' -> False -- '+'
      '\x2C' -> False -- ','
      '\x3B' -> False -- ';'
      '\x3C' -> False -- '<'
      '\x3E' -> False -- '>'
      '\x5C' -> False -- '\\'
      _      -> True

    -- pair = ESC ( ESC / special / hexpair )
    p'pair = do
      _ <- char '\\'
      (CEsc <$> satisfy isEscOrSpecial) <|> (CHex <$> p'hexpairsUtf8)

    -- special = escaped / SPACE / SHARP / EQUALS
    -- escaped = DQUOTE / PLUS / COMMA / SEMI / LANGLE / RANGLE
    isEscOrSpecial c = case c of
      '\\' -> True

      '"'  -> True
      '+'  -> True
      ','  -> True
      ';'  -> True
      '<'  -> True
      '>'  -> True

      ' '  -> True
      '#'  -> True
      '='  -> True

      _    -> False

    -- hexstring = SHARP 1*hexpair
    p'hexstring = do
      _ <- char '#'
      octets <- many1 p'hexpair
      pure $ BS.pack octets

data C = C    { unescape :: !Char } -- unescaped character
       | CEsc { unescape :: !Char } -- backslash escaped character
       | CHex { unescape :: !Char } -- hex pairs encoded utf8 code-point
       deriving (Show,Eq)

-- ; Any UTF-8 [RFC3629] encoded Unicode [Unicode] character
p'hexpairsUtf8 :: Stream s Identity Char => Parsec s () Char
p'hexpairsUtf8 = do
    -- UTF8    = UTF1 / UTFMB
    -- UTFMB   = UTF2 / UTF3 / UTF4
    o0 <- p'hexpair
    case () of
        -- UTF1    = %x00-7F
      _ | o0 <= 0x7f -> pure $! chr (fromIntegral o0)

        -- UTF2    = %xC2-DF UTF0
        | o0 `inside` (0xc2,0xdf) -> do
            let o0' = fromIntegral (o0 .&. 0x1f) `unsafeShiftL` 6
            o1' <- p'utf0
            pure $! chr (o0' .|. o1')

        -- UTF3    = %xE0 %xA0-BF UTF0 / %xE1-EC 2(UTF0) / %xED %x80-9F UTF0 / %xEE-EF 2(UTF0)
        | o0 == 0xe0 -> do
            let o0' = fromIntegral (o0 .&. 0x0f) `unsafeShiftL` 12
            o1' <- (`unsafeShiftL` 6) <$> p'utf0' 0xa0 0xbf
            o2' <- p'utf0
            pure $! chr (o0' .|. o1' .|. o2')
        | o0 == 0xed -> do
            let o0' = fromIntegral (o0 .&. 0x0f) `unsafeShiftL` 12
            o1' <- (`unsafeShiftL` 6) <$> p'utf0' 0x80 0x9f
            o2' <- p'utf0
            pure $! chr (o0' .|. o1' .|. o2')
        | o0 `inside` (0xe1,0xef) -> do -- NB: 0xed excluded due to preceding case
            let o0' = fromIntegral (o0 .&. 0x0f) `unsafeShiftL` 12
            o1' <- (`unsafeShiftL` 6) <$> p'utf0
            o2' <- p'utf0
            pure $! chr (o0' .|. o1' .|. o2')

        -- UTF4    = %xF0 %x90-BF 2(UTF0) / %xF1-F3 3(UTF0) / %xF4 %x80-8F 2(UTF0)
        | o0 == 0xf0 -> do
            let o0' = fromIntegral (o0 .&. 0x07) `unsafeShiftL` 18
            o1' <- (`unsafeShiftL` 12) <$> p'utf0' 0x90 0xbf
            o2' <- (`unsafeShiftL` 6) <$> p'utf0
            o3' <- p'utf0
            pure $! chr (o0' .|. o1' .|. o2' .|. o3')
        | o0 `inside` (0xf1,0xf3) -> do
            let o0' = fromIntegral (o0 .&. 0x07) `unsafeShiftL` 18
            o1' <- (`unsafeShiftL` 12) <$> p'utf0
            o2' <- (`unsafeShiftL` 6) <$> p'utf0
            o3' <- p'utf0
            pure $! chr (o0' .|. o1' .|. o2' .|. o3')
        | o0 == 0xf4 -> do
            let o0' = fromIntegral (o0 .&. 0x07) `unsafeShiftL` 18
            o1' <- (`unsafeShiftL` 12) <$> p'utf0' 0x80 0x8f
            o2' <- (`unsafeShiftL` 6) <$> p'utf0
            o3' <- p'utf0
            pure $! chr (o0' .|. o1' .|. o2' .|. o3')

        -- everything else is not a valid UTF8 encoded code-point
        | otherwise -> utf8fail

  where
    -- UTF0    = %x80-BF
    p'utf0 = p'utf0' 0x80 0xbf

    p'utf0' lb ub = do
      _ <- char '\\'
      o <- p'hexpair
      unless (o `inside` (lb,ub)) $ utf8fail
      pure $ (fromIntegral $ o .&. 0x3f)

    utf8fail = fail "unexpected hex-encoded UTF8 octet"

-- hexpair = HEX HEX
p'hexpair :: Stream s Identity Char => Parsec s () Word8
p'hexpair = ((\hi lo -> hi*16 + lo) <$> p'HEX <*> p'HEX)

p'HEX :: Stream s Identity Char => Parsec s () Word8
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              = impossible

b'ShortText :: ShortText -> Builder
b'ShortText = fromText . TS.toText