{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE ScopedTypeVariables  #-}

module Raaz.Digest.Blake2Spec where

import           Prelude hiding (replicate)

import           Tests.Core
import           Data.Attoparsec.ByteString.Char8 as AP
import qualified Data.ByteString                  as BS
import           Data.Char
import           Raaz.Primitive.Keyed.Internal
import           Paths_raaz

import qualified Blake2b.Digest as B2b
import qualified Blake2b.Auth   as B2bAuth
import qualified Blake2s.Digest as B2s
import qualified Blake2s.Auth   as B2sAuth

spec :: Spec
spec = do
  describe "BLAKE2b" $ do
    basicEndianSpecs (undefined :: Blake2b)
    B2b.incrementalVsFull
    B2bAuth.incrementalVsFull

  describe "BLAKE2s" $ do
    basicEndianSpecs (undefined :: Blake2s)
    B2s.incrementalVsFull
    B2sAuth.incrementalVsFull

  -- | Running the standard test cases.
  let process hand = parseWith (slurp hand) tests BS.empty
      slurp   hand = BS.hGetSome hand $ 32 * 1024
      reportFailure l str = prop l $ counterexample str False
    in do

    result <- runIO $ do
      fp    <- getDataFileName "tests/standard-test-vectors/blake2/tests.json"
      withFile fp ReadMode process

    case result of
      Done _ testCases -> mapM_ toSpec testCases
      Fail _ _ err     -> reportFailure "Parse Error" err
      _                -> reportFailure "fatal" "something terrible happened may be incomplete file"



----------------------------- Parsing functions ------------------------


data B2Test = B2b (Test Blake2b)
            | B2s (Test Blake2s)
            | Skip ByteString

data Test h = HT ByteString h
            | AT ByteString (Key (Keyed h)) (Keyed h)

toSpec :: B2Test -> Spec
toSpec tst  =
  case tst of
    B2b (HT bs h)     -> context "with blake2b" $ B2b.digestsTo bs h
    B2b (AT bs k tag) -> withKey "blake2b" k    $ bs `B2bAuth.authsTo` tag
    B2s (HT bs h)     -> context "with blake2s" $ B2s.digestsTo bs h
    B2s (AT bs k tag) -> withKey "blake2s" k    $ bs `B2sAuth.authsTo` tag
    _                 -> return ()
  where withKey hsh key = context (unwords ["with key", shortened $ show key, hsh]) . with key



hashTest :: Encodable h => Proxy h -> Parser (Test h)
hashTest _ = do  i    <- byteStringField "in" <* comma
                 kstr <- byteStringField "key" <* comma
                 if BS.null kstr then HT i <$> encodableField "out"
                   else AT i (unsafeDecode kstr) <$> encodableField "out"

b2Test :: Parser B2Test
b2Test = brace (b2bTest <|> b2sTest <|> unknown)
  where b2bTest = hashField "blake2b" >> comma >> B2b <$> hashTest (Proxy :: Proxy Blake2b)
        b2sTest = hashField "blake2s" >> comma >> B2s <$> hashTest (Proxy :: Proxy Blake2s)
        unknown = do h <- field "hash"  $ quoted $ AP.takeWhile (/= '"')
                     skipWhile (/= '}')
                     return $ Skip h



tests :: Parser [B2Test]
tests = skipSpace >> bracket (b2Test `sepBy` comma)


------------ Fields ----------------------------------
hashField :: ByteString -> Parser ByteString
hashField h = field "hash" (quoted $ string h)



byteStringField :: ByteString -> Parser ByteString
byteStringField s =  field s  (decodeFormat <$> base16)

encodableField :: Encodable a => ByteString -> Parser a
encodableField s = field s (unsafeDecode <$> base16)

base16 :: Parser Base16
base16 = hex >>= maybe (fail "bad base16 string") return
  where hex    :: Parser (Maybe Base16)
        hex    = decode <$> quoted (AP.takeWhile isHexDigit)




-- | Parse something and skip spaces.
lexeme :: Parser a -> Parser a
lexeme p = p <* skipSpace

-- A json field (key value pair).
field :: BS.ByteString -> Parser a -> Parser a
field s p = quoted (string s) >> colon >> p



-- | Some common character parsers.
lbrack      :: Parser Char
rbrack      :: Parser Char
lbrace      :: Parser Char
rbrace      :: Parser Char
colon       :: Parser Char
semiColon   :: Parser Char
quote       :: Parser Char
comma       :: Parser Char


lbrack    = lexeme $ char '['
rbrack    = lexeme $ char ']'
lbrace    = lexeme $ char '{'
rbrace    = lexeme $ char '}'
colon     = lexeme $ char ':'
semiColon = lexeme $ char ';'
comma     = lexeme $ char ','
quote     = lexeme $ char '"'

between :: Parser begin -> Parser end -> Parser a -> Parser a
between begin end p = lexeme $ do x <- begin >> p
                                  end >> return x


bracket :: Parser a -> Parser a
bracket = between lbrack rbrack

brace :: Parser a -> Parser a
brace = between lbrace rbrace

quoted :: Parser a -> Parser a
quoted = between quote quote