module Network.DNS.Base32Hex (encode) where

import qualified Data.Array.MArray as A
import qualified Data.Array.IArray as A
import qualified Data.Array.ST     as A
import qualified Data.ByteString   as B

import Network.DNS.Imports

-- | Encode ByteString using the
-- <https://tools.ietf.org/html/rfc4648#section-7 RFC4648 base32hex>
-- encoding with no padding as specified for the
-- <https://tools.ietf.org/html/rfc5155#section-3.3 RFC5155 Next Hashed Owner Name>
-- field.
--
encode :: B.ByteString -- ^ input buffer
       -> B.ByteString -- ^ base32hex output
encode :: ByteString -> ByteString
encode ByteString
bs =
    let len :: Int
len = (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* ByteString -> Int
B.length ByteString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
5
        ws :: [Word8]
ws  = ByteString -> [Word8]
B.unpack ByteString
bs
     in [Word8] -> ByteString
B.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ UArray Int Word8 -> [Word8]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
A.elems (UArray Int Word8 -> [Word8]) -> UArray Int Word8 -> [Word8]
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (STUArray s Int Word8)) -> UArray Int Word8
forall i e. (forall s. ST s (STUArray s i e)) -> UArray i e
A.runSTUArray ((forall s. ST s (STUArray s Int Word8)) -> UArray Int Word8)
-> (forall s. ST s (STUArray s Int Word8)) -> UArray Int Word8
forall a b. (a -> b) -> a -> b
$ do
        a <- (Int, Int) -> Word8 -> ST s (STUArray s Int Word8)
forall i. Ix i => (i, i) -> Word8 -> ST s (STUArray s i Word8)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
A.newArray (Int
0 :: Int, Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Word8
0
        go ws a 0
  where
    toHex32 :: a -> a
toHex32 a
w | a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
10    = a
48 a -> a -> a
forall a. Num a => a -> a -> a
+ a
w
              | Bool
otherwise = a
55 a -> a -> a
forall a. Num a => a -> a -> a
+ a
w

    load8 :: a i e -> i -> m e
load8  a i e
a i
i   = a i e -> i -> m e
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
A.readArray  a i e
a i
i
    store8 :: a i e -> i -> e -> m ()
store8 a i e
a i
i e
v = a i e -> i -> e -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
A.writeArray a i e
a i
i e
v

    -- Encode a list of 8-bit words at bit offset @n@
    -- into an array 'a' of 5-bit words.
    go :: [e] -> a Int e -> Int -> m (a Int e)
go [] a Int e
a Int
_ = (e -> e) -> a Int e -> m (a Int e)
forall (a :: * -> * -> *) e' (m :: * -> *) e i.
(MArray a e' m, MArray a e m, Ix i) =>
(e' -> e) -> a i e' -> m (a i e)
A.mapArray e -> e
forall {a}. (Ord a, Num a) => a -> a
toHex32 a Int e
a
    go (e
w:[e]
ws) a Int e
a Int
n = do
        -- Split 8 bits into left, middle and right parts.  The
        -- right part only gets written when the 8-bit input word
        -- splits across three different 5-bit words.
        --
        let (Int
q, Int
r) = Int
n Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
5
            wl :: e
wl =  e
w e -> Int -> e
forall a. Bits a => a -> Int -> a
`shiftR` ( Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
r)
            wm :: e
wm = (e
w e -> Int -> e
forall a. Bits a => a -> Int -> a
`shiftL` ( Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r))  e -> Int -> e
forall a. Bits a => a -> Int -> a
`shiftR` Int
3
            wr :: e
wr = (e
w e -> Int -> e
forall a. Bits a => a -> Int -> a
`shiftL` (Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r)) e -> Int -> e
forall a. Bits a => a -> Int -> a
`shiftR` Int
3
        al <- case Int
r of
              Int
0 -> e -> m e
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure e
wl
              Int
_ -> (e
wl e -> e -> e
forall a. Bits a => a -> a -> a
.|.) (e -> e) -> m e -> m e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a Int e -> Int -> m e
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
load8 a Int e
a Int
q
        store8 a q al
        store8 a (q + 1) wm
        when (r > 2) $ store8 a (q+2) wr
        go ws a $ n + 8
{-# INLINE encode #-}