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 bs :: ByteString
bs =
    let len :: Int
len = (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
+ 4) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 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
        STUArray s Int Word8
a <- (Int, Int) -> Word8 -> ST s (STUArray s Int Word8)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
A.newArray (0 :: Int, Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) 0
        [Word8]
-> STUArray s Int Word8 -> Int -> ST s (STUArray s Int Word8)
forall (a :: * -> * -> *) e (m :: * -> *).
(MArray a e m, Ord e, Num e, Bits e) =>
[e] -> a Int e -> Int -> m (a Int e)
go [Word8]
ws STUArray s Int Word8
a 0
  where
    toHex32 :: a -> a
toHex32 w :: a
w | a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< 10    = 48 a -> a -> a
forall a. Num a => a -> a -> a
+ a
w
              | Bool
otherwise = 55 a -> a -> a
forall a. Num a => a -> a -> a
+ a
w

    load8 :: a i e -> i -> m e
load8  a :: a i e
a i :: 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 :: a i e
a i :: i
i v :: 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 :: a Int e
a _ = (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 (w :: e
w:ws :: [e]
ws) a :: a Int e
a n :: 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 (q :: Int
q, r :: Int
r) = Int
n Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` 5
            wl :: e
wl =  e
w e -> Int -> e
forall a. Bits a => a -> Int -> a
`shiftR` ( 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` ( 5 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r))  e -> Int -> e
forall a. Bits a => a -> Int -> a
`shiftR` 3
            wr :: e
wr = (e
w e -> Int -> e
forall a. Bits a => a -> Int -> a
`shiftL` (10 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r)) e -> Int -> e
forall a. Bits a => a -> Int -> a
`shiftR` 3
        e
al <- case Int
r of
              0 -> e -> m e
forall (f :: * -> *) a. Applicative f => a -> f a
pure e
wl
              _ -> (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
        a Int e -> Int -> e -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
store8 a Int e
a Int
q e
al
        a Int e -> Int -> e -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
store8 a Int e
a (Int
q Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) e
wm
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 2) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ a Int e -> Int -> e -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
store8 a Int e
a (Int
qInt -> Int -> Int
forall a. Num a => a -> a -> a
+2) e
wr
        [e] -> a Int e -> Int -> m (a Int e)
go [e]
ws a Int e
a (Int -> m (a Int e)) -> Int -> m (a Int e)
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 8
{-# INLINE encode #-}