{-# LANGUAGE BangPatterns #-}

module Ouroboros.Consensus.Util.CRC
  ( CRCError (..)
  , crcOfConcat
  , readCRC
  ) where

import Control.Monad.Class.MonadThrow
import Control.Monad.Except
import Data.Bits
import qualified Data.ByteString.Builder as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BSL
import Data.Char hiding (isHexDigit)
import System.FS.API
import System.FS.API.Lazy
import System.FS.CRC

crcOfConcat :: CRC -> CRC -> CRC
crcOfConcat :: CRC -> CRC -> CRC
crcOfConcat CRC
crc1 CRC
crc2 =
  StrictByteString -> CRC
forall a. CRC32 a => a -> CRC
computeCRC (StrictByteString -> CRC) -> StrictByteString -> CRC
forall a b. (a -> b) -> a -> b
$
    LazyByteString -> StrictByteString
BSL.toStrict (LazyByteString -> StrictByteString)
-> LazyByteString -> StrictByteString
forall a b. (a -> b) -> a -> b
$
      Builder -> LazyByteString
BS.toLazyByteString (Builder -> LazyByteString) -> Builder -> LazyByteString
forall a b. (a -> b) -> a -> b
$
        (Word32 -> Builder
BS.word32Dec (Word32 -> Builder) -> Word32 -> Builder
forall a b. (a -> b) -> a -> b
$ CRC -> Word32
getCRC CRC
crc1)
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Word32 -> Builder
BS.word32Dec (Word32 -> Builder) -> Word32 -> Builder
forall a b. (a -> b) -> a -> b
$ CRC -> Word32
getCRC CRC
crc2)

data CRCError
  = CRCInvalid
  | CRCNoFile
  deriving (CRCError -> CRCError -> Bool
(CRCError -> CRCError -> Bool)
-> (CRCError -> CRCError -> Bool) -> Eq CRCError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CRCError -> CRCError -> Bool
== :: CRCError -> CRCError -> Bool
$c/= :: CRCError -> CRCError -> Bool
/= :: CRCError -> CRCError -> Bool
Eq, Int -> CRCError -> ShowS
[CRCError] -> ShowS
CRCError -> String
(Int -> CRCError -> ShowS)
-> (CRCError -> String) -> ([CRCError] -> ShowS) -> Show CRCError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CRCError -> ShowS
showsPrec :: Int -> CRCError -> ShowS
$cshow :: CRCError -> String
show :: CRCError -> String
$cshowList :: [CRCError] -> ShowS
showList :: [CRCError] -> ShowS
Show)

readCRC ::
  MonadThrow m =>
  HasFS m h ->
  FsPath ->
  ExceptT CRCError m CRC
readCRC :: forall (m :: * -> *) h.
MonadThrow m =>
HasFS m h -> FsPath -> ExceptT CRCError m CRC
readCRC HasFS m h
hasFS FsPath
crcPath = m (Either CRCError CRC) -> ExceptT CRCError m CRC
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either CRCError CRC) -> ExceptT CRCError m CRC)
-> m (Either CRCError CRC) -> ExceptT CRCError m CRC
forall a b. (a -> b) -> a -> b
$ do
  crcExists <- HasFS m h -> HasCallStack => FsPath -> m Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesFileExist HasFS m h
hasFS FsPath
crcPath
  if not crcExists
    then pure (Left CRCNoFile)
    else do
      withFile hasFS crcPath ReadMode $ \Handle h
h -> do
        str <- LazyByteString -> StrictByteString
BSL.toStrict (LazyByteString -> StrictByteString)
-> m LazyByteString -> m StrictByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasFS m h -> Handle h -> m LazyByteString
forall (m :: * -> *) h.
Monad m =>
HasFS m h -> Handle h -> m LazyByteString
hGetAll HasFS m h
hasFS Handle h
h
        if not (BSC.length str == 8 && BSC.all isHexDigit str)
          then pure (Left CRCInvalid)
          else pure . Right . CRC $ fromIntegral (hexdigitsToInt str)
 where
  -- TODO: remove the functions in the where clause when we start depending on lsm-tree

  isHexDigit :: Char -> Bool
  isHexDigit :: Char -> Bool
isHexDigit Char
c =
    (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9')
      Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'f') -- lower case only

  -- Precondition: BSC.all isHexDigit
  hexdigitsToInt :: BSC.ByteString -> Word
  hexdigitsToInt :: StrictByteString -> Word
hexdigitsToInt =
    (Word -> Char -> Word) -> Word -> StrictByteString -> Word
forall a. (a -> Char -> a) -> a -> StrictByteString -> a
BSC.foldl' Word -> Char -> Word
accumdigit Word
0
   where
    accumdigit :: Word -> Char -> Word
    accumdigit :: Word -> Char -> Word
accumdigit !Word
a !Char
c =
      (Word
a Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftL` Int
4) Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Char -> Word
hexdigitToWord Char
c

  -- Precondition: isHexDigit
  hexdigitToWord :: Char -> Word
  hexdigitToWord :: Char -> Word
hexdigitToWord Char
c
    | let !dec :: Word
dec = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'0')
    , Word
dec Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
9 =
        Word
dec
    | let !hex :: Word
hex = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'a' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10)
    , Bool
otherwise =
        Word
hex