Checksum.hs

module Telescope.Fits.Checksum where

import Data.Bits (complement, shiftR, (.&.))
import Data.ByteString.Internal
import Data.Fits (Value (..))
import Data.Text (Text, pack)
import Data.Word
import Foreign.C.String
import Foreign.C.Types
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Ptr
import GHC.IO


-- | Generate the Checksum per the FITS spec
checksum :: ByteString -> Checksum
checksum bs = unsafePerformIO $ do
  let (fptr, offset, len) = toForeignPtr bs
  withForeignPtr fptr $ \ptr -> do
    ci <- c_checksum (ptr `plusPtr` offset) (fromIntegral len)
    pure $ Checksum $ fromIntegral ci


-- | Encode the Checksum as ASCII chars per FITS spec
encodeChecksum :: Checksum -> Text
encodeChecksum (Checksum csum) =
  unsafePerformIO $ do
    let comp = complement csum
    let str = replicate 16 ' '
    out <- withCString str $ \cs -> do
      c_char_encode (fromIntegral comp) cs
      peekCString cs
    pure $ pack out


foreign import ccall "checksum" c_checksum :: Ptr CChar -> CInt -> IO CUInt


newtype Checksum = Checksum Word32
  deriving (Eq, Show)


instance Semigroup Checksum where
  Checksum w1 <> Checksum w2 = Checksum (add1s w1 w2)


checksumValue :: Checksum -> Value
checksumValue (Checksum s) = String (pack (show s))


foreign import ccall "char_encode" c_char_encode :: CUInt -> CString -> IO ()


add1s :: Word32 -> Word32 -> Word32
add1s x y =
  let
    sum64 = (+) @Word64 (fromIntegral x) (fromIntegral y)
    result =
      if sum64 > maxWord32
        then (sum64 .&. maxWord32) + (sum64 `shiftR` 32)
        else sum64
   in
    fromIntegral result
 where
  maxWord32 :: Word64
  maxWord32 = 0xFFFFFFFF