{-# LINE 1 "src/Graphics/WOFF.hsc" #-}
{-# LANGUAGE CPP, ForeignFunctionInterface #-}
{-# LINE 2 "src/Graphics/WOFF.hsc" #-}

-----------------------------------------------------------------------------
---- |
---- Module      :  Graphics.WOFF
---- Copyright   :  (c) Kwang Yul Seo 2016
---- License     :  BSD-style (see the file LICENSE)
---- 
---- Maintainer  :  kwangyul.seo@gmail.com
---- Stability   :  experimental
---- Portability :  portable
----
---- Utilities for primitive marshaling
----
-------------------------------------------------------------------------------
module Graphics.WOFF
  (
  -- ** Encoding woff
  --
    encode
  , EncodeResult
  , ErrorCode(OutOfMemory, Invalid, CompressionFailure, BadSignature, BufferToSmall, BadParameter, IllegalOrder)
  , Warning(..)
  -- ** Setting metadata and private data
  -- | (argument order: woff, data)
  --
  , setMetadata
  , setPrivateData
  ) where

import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BS
import Data.Bits
import Data.Word
import Foreign
import Foreign.C.String
import Foreign.C.Types
import Foreign.Marshal.Alloc
import Foreign.Marshal.Utils


{-# LINE 43 "src/Graphics/WOFF.hsc" #-}

type EncodeResult = Either ErrorCode (ByteString, [Warning])

data ErrorCode =
    Ok
  | OutOfMemory
  | Invalid
  | CompressionFailure
  | BadSignature
  | BufferToSmall
  | BadParameter
  | IllegalOrder
  deriving (Eq)

instance Show ErrorCode where
  show Ok = "ok"
  show OutOfMemory = "memory allocation failure"
  show Invalid = "invalid input font"
  show CompressionFailure = "zlib compression/decompression failure"
  show BadSignature = "incorrect WOFF file signature"
  show BufferToSmall = "buffer too small"
  show BadParameter = "bad parameter to WOFF function"
  show IllegalOrder = "unknown internal error"

data Warning =
    UnknownVersion
  | ChecksumMismatch
  | MisalignedTable
  | TrailingData
  | UnpaddedTable
  | RemovedDSIG
  deriving (Eq)

instance Show Warning where
  show UnknownVersion = "unrecognized sfnt version"
  show ChecksumMismatch = "checksum mismatch (corrected)"
  show MisalignedTable = "misaligned font table"
  show TrailingData = "extraneous input data discarded"
  show UnpaddedTable = "final table not correctly padded"
  show RemovedDSIG = "digital signature (DSIG) table removed"

toWarnings :: CUInt -> [Warning]
toWarnings cWarnings = 
  let matchingFlags = filter (testFlag cWarnings) warningFlags
   in map (flagToWarning . fromIntegral) matchingFlags
  where
    testFlag x y = x .&. y /= 0

    warningFlags =
      [ 256
{-# LINE 93 "src/Graphics/WOFF.hsc" #-}
      , 512
{-# LINE 94 "src/Graphics/WOFF.hsc" #-}
      , 1024
{-# LINE 95 "src/Graphics/WOFF.hsc" #-}
      , 2048
{-# LINE 96 "src/Graphics/WOFF.hsc" #-}
      , 4096
{-# LINE 97 "src/Graphics/WOFF.hsc" #-}
      , 8192
{-# LINE 98 "src/Graphics/WOFF.hsc" #-}
      ]

    flagToWarning 256 = UnknownVersion
{-# LINE 101 "src/Graphics/WOFF.hsc" #-}
    flagToWarning 512 = ChecksumMismatch
{-# LINE 102 "src/Graphics/WOFF.hsc" #-}
    flagToWarning 1024 = MisalignedTable
{-# LINE 103 "src/Graphics/WOFF.hsc" #-}
    flagToWarning 2048 = TrailingData
{-# LINE 104 "src/Graphics/WOFF.hsc" #-}
    flagToWarning 4096 = UnpaddedTable
{-# LINE 105 "src/Graphics/WOFF.hsc" #-}
    flagToWarning 8192 = RemovedDSIG
{-# LINE 106 "src/Graphics/WOFF.hsc" #-}

toErrorCode :: CUInt -> ErrorCode
toErrorCode 0 = Ok
{-# LINE 109 "src/Graphics/WOFF.hsc" #-}
toErrorCode 1 = OutOfMemory
{-# LINE 110 "src/Graphics/WOFF.hsc" #-}
toErrorCode 2 = Invalid
{-# LINE 111 "src/Graphics/WOFF.hsc" #-}
toErrorCode 3 = CompressionFailure
{-# LINE 112 "src/Graphics/WOFF.hsc" #-}
toErrorCode 4 = BadSignature
{-# LINE 113 "src/Graphics/WOFF.hsc" #-}
toErrorCode 5 = BufferToSmall
{-# LINE 114 "src/Graphics/WOFF.hsc" #-}
toErrorCode 6 = BadParameter
{-# LINE 115 "src/Graphics/WOFF.hsc" #-}
toErrorCode 7 = IllegalOrder
{-# LINE 116 "src/Graphics/WOFF.hsc" #-}

statusToErrorCodeAndWarnigns :: CUInt -> (ErrorCode, [Warning])
statusToErrorCodeAndWarnigns cStatus =
  (toErrorCode $ fromIntegral (cStatus .&. 0xff), toWarnings (clearBit cStatus 0xff))

wrapResult :: Ptr CUInt -> CString -> Ptr CUInt -> IO EncodeResult
wrapResult statusPtr woffData woffLenPtr = do
  status <- peek statusPtr
  let (errorCode, warnings) = statusToErrorCodeAndWarnigns status
  case errorCode of
    Ok -> do
      woffLen <- peek woffLenPtr
      woff <- BS.unsafePackMallocCStringLen (woffData, fromIntegral woffLen)
      return $ Right (woff, warnings)
    _ -> return $ Left errorCode

-- | Encode the OpenType/TrueType fonts into WOFF format
encode :: ByteString -> Word16 -> Word16 -> IO EncodeResult
encode sfnt major minor =
  BS.unsafeUseAsCStringLen sfnt $ \(sfntData, sfntLen) -> (
  alloca $ \woffLenPtr -> (
  alloca $ \statusPtr -> do
    woffData <- cWoffEncode sfntData (CUInt (fromIntegral sfntLen)) (CUShort major) (CUShort minor) woffLenPtr statusPtr
    wrapResult statusPtr woffData woffLenPtr))

-- | Add the given metadata block to the WOFF font, replacing any exisiting
-- metadata block. The block will be zlib-compressed.
-- Metadata is required to be valid XML (use of UTF-8 is recommended),
-- though this function does not currently check this.
setMetadata :: ByteString -> ByteString -> IO EncodeResult
setMetadata woff meta =
  BS.unsafeUseAsCStringLen woff $ \(woffData, woffLen) -> (
  BS.unsafeUseAsCStringLen meta $ \(metaData, metaLen) -> (
  alloca $ \woffLenPtr -> (
  alloca $ \statusPtr -> do
    poke woffLenPtr (CUInt (fromIntegral woffLen))
    woffDataTmp <- mallocBytes woffLen
    copyBytes woffDataTmp woffData woffLen
    woffData <- cWoffSetMetadata woffDataTmp woffLenPtr metaData (CUInt (fromIntegral metaLen)) statusPtr
    wrapResult statusPtr woffData woffLenPtr)))

-- | Add the given private data block to the WOFF font, replacing any exisiting
-- private block. The block will NOT be zlib-compressed.
-- Private data may be any arbitrary block of bytes; it may be externally
-- compressed by the client if desired.
setPrivateData :: ByteString -> ByteString -> IO EncodeResult
setPrivateData woff priv =
  BS.unsafeUseAsCStringLen woff $ \(woffData, woffLen) -> (
  BS.unsafeUseAsCStringLen priv $ \(privData, privLen) -> (
  alloca $ \woffLenPtr -> (
  alloca $ \statusPtr -> do
    poke woffLenPtr (CUInt (fromIntegral woffLen))
    woffDataTmp <- mallocBytes woffLen
    copyBytes woffDataTmp woffData woffLen
    woffData <- cWoffSetPrivateData woffDataTmp woffLenPtr privData (CUInt (fromIntegral privLen)) statusPtr
    wrapResult statusPtr woffData woffLenPtr)))

foreign import ccall unsafe "woff.h woffEncode"
  cWoffEncode :: CString
              -> CUInt
              -> CUShort
              -> CUShort
              -> Ptr CUInt
              -> Ptr CUInt
              -> IO CString

foreign import ccall unsafe "woff.h woffSetMetadata"
  cWoffSetMetadata :: CString
                   -> Ptr CUInt
                   -> CString
                   -> CUInt
                   -> Ptr CUInt
                   -> IO CString

foreign import ccall unsafe "woff.h woffSetPrivateData"
  cWoffSetPrivateData :: CString
                      -> Ptr CUInt
                      -> CString
                      -> CUInt
                      -> Ptr CUInt
                      -> IO CString