{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

module Hsm.Cam
  ( Cam
  , capturePng
  , runCam
  ) where

import Codec.Picture (Image(Image), encodePng)
import Codec.Picture.Types (PixelRGB8)
import Control.Concurrent (MVar, forkIO, newEmptyMVar, putMVar, takeMVar)
import Control.Exception (mask_)
import Control.Monad (forever)
import Control.Monad.Loops (whileM_)
import Data.Bits ((.|.))
import Data.ByteString.Lazy (ByteString)
import Data.List ((!?))
import Data.Primitive.Ptr (readOffPtr)
import Data.Vector.Storable (generateM)
import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>), liftIO)
import Effectful.Dispatch.Static (SideEffects(WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unsafeEff_)
import Effectful.Exception (bracket, bracket_)
import Foreign.C.String (peekCString)
import Foreign.C.Types (CSize(CSize))
import Foreign.Ptr (Ptr, castPtr, freeHaskellFunPtr, nullPtr)
import Hsm.Cam.FFI
  ( acquireCamera
  , allocateFrameBuffer
  , createRequest
  , frameHeight
  , frameWidth
  , freeFrameBuffer
  , getDmaBufferFd
  , makeLogger
  , makeRequestCallback
  , registerLogger
  , registerRequestCallback
  , releaseCamera
  , requestFrame
  , startCamera
  , startCameraManager
  , stopCamera
  , stopCameraManager
  )
import Hsm.Core.Bracket (bracketConst, bracketLiftIO_)
import Hsm.Log (Log, Severity(Attention, Info, Trace), getLevel, logMsg, makeLoggerIO)
import MMAP (mapShared, mkMmapFlags, mmap, munmap, protRead)
import System.Directory (doesFileExist, removeFile)
import System.Environment (setEnv)
import System.IO (IOMode(ReadWriteMode), hGetLine, withFile)
import System.Posix.Files (createNamedPipe, ownerReadMode, ownerWriteMode)
import Text.Read (readMaybe)

data Cam (a :: * -> *) (b :: *)

type instance DispatchOf Cam = Static WithSideEffects

data Rep = Rep
  { requestCallbackMVar :: MVar ()
  , dmaBuffer :: Ptr ()
  }

newtype instance StaticRep Cam =
  Cam Rep

-- RGB888 configuration for ov5647 sensor (Raspberry Pi Camera Module)
-- The following constants must be updated if either:
-- - Pixel format changes (e.g., to BGR, YUV, etc.)
-- - Camera module is replaced
frameLine :: Int
frameLine = frameWidth * 3

frameStride :: Int
frameStride = frameLine + 32

frameBufferLength :: Int
frameBufferLength = frameStride * frameHeight + 3072

capturePng :: (Log "cam" :> es, Cam :> es) => Eff es ByteString
capturePng = do
  Cam Rep {..} <- getStaticRep
  logMsg Trace "Requesting frame"
  unsafeEff_ . mask_ $ requestFrame >> takeMVar requestCallbackMVar
  logMsg Trace "Processing frame data"
  pixelVector <- unsafeEff_ . generateM (frameLine * frameHeight) $ mapPixel dmaBuffer
  logMsg Trace "Encoding PNG"
  return . encodePng $ Image @PixelRGB8 frameWidth frameHeight pixelVector
  where
    mapPixel dmaBuffer index = readOffPtr (castPtr dmaBuffer) offset
      where
        yIndex = index `div` frameLine
        xIndex = index `mod` frameLine
        offset = yIndex * frameStride + xIndex

-- Bidirectional mapping between libcamera's logging system and application logs.
-- All libcamera warnings and errors are elevated to the application's
-- 'Attention' level to ensure visibility.
data LibCameraSeverity
  = DEBUG
  | INFO
  | WARN
  | ERROR
  | FATAL
  deriving (Read, Show)

toLibCameraSeverity :: Severity -> LibCameraSeverity
toLibCameraSeverity Trace = DEBUG
toLibCameraSeverity Info = INFO
toLibCameraSeverity Attention = WARN

fromLibCameraSeverity :: LibCameraSeverity -> Severity
fromLibCameraSeverity DEBUG = Trace
fromLibCameraSeverity INFO = Info
fromLibCameraSeverity _ = Attention

runCam :: (IOE :> es, Log "cam" :> es, Log "libcamera" :> es) => Eff (Cam : es) a -> Eff es a
runCam action = do
  requestCallbackMVar <- liftIO newEmptyMVar
  bracketConst loggerAlloc loggerDealloc
    . bracketConst (requestCallbackAlloc requestCallbackMVar) requestCallbackDealloc
    . bracket_ logCaptureAlloc logCaptureDealloc
    . bracketLiftIO_ startCameraManager stopCameraManager
    . bracketLiftIO_ acquireCamera releaseCamera
    . bracketLiftIO_ allocateFrameBuffer freeFrameBuffer
    . bracketLiftIO_ startCamera stopCamera
    . bracketLiftIO_ createRequest (return ())
    . bracket mapDmaBuffer unmapDmaBuffer $ \dmaBuffer -> evalStaticRep (Cam Rep {..}) action
  where
    loggerAlloc = do
      logMsg @"cam" Info "Registering FFI logger"
      loggerIO <- makeLoggerIO @"cam"
      loggerFFI <- liftIO . makeLogger $ \severity message -> peekCString message >>= loggerIO (toEnum severity)
      liftIO $ registerLogger loggerFFI
      return loggerFFI
    loggerDealloc loggerFFI = do
      logMsg @"cam" Info "Unregistering FFI logger"
      liftIO $ freeHaskellFunPtr loggerFFI
    requestCallbackAlloc requestCallbackMVar = do
      logMsg @"cam" Info "Registering FFI request callback"
      requestCallbackFFI <- liftIO . makeRequestCallback $ putMVar requestCallbackMVar ()
      liftIO $ registerRequestCallback requestCallbackFFI
      return requestCallbackFFI
    requestCallbackDealloc requestCallbackFFI = do
      logMsg @"cam" Info "Unregistering FFI request callback"
      liftIO $ freeHaskellFunPtr requestCallbackFFI
    -- We use a named pipe (FIFO) to intercept libcamera's log output. The environment
    -- variables `LIBCAMERA_LOG_FILE` and `LIBCAMERA_LOG_LEVELS` configure libcamera
    -- to write logs to the FIFO with appropriate severity filtering.
    --
    -- A dedicated thread reads from the FIFO, parses log severity levels, and
    -- forwards messages to the application's logger with proper level mapping.
    logCaptureFifo = "/tmp/hsm-cam-libcamera.fifo"
    logCaptureClear = liftIO . whileM_ (doesFileExist logCaptureFifo) $ removeFile logCaptureFifo
    logCaptureSetEnvVar key value = do
      logMsg @"cam" Info $ "Setting env variable: " <> key <> "=" <> value
      liftIO $ setEnv key value
    logCaptureLineSeverity logLine = maybe Trace fromLibCameraSeverity $ words logLine !? 2 >>= readMaybe
    logCaptureAlloc = do
      logCaptureClear
      logMsg @"cam" Info $ "Creating libcamera log capture FIFO at: " <> logCaptureFifo
      liftIO . createNamedPipe logCaptureFifo $ ownerReadMode .|. ownerWriteMode
      libCameraSeverity <- toLibCameraSeverity <$> getLevel @"libcamera"
      logCaptureSetEnvVar "LIBCAMERA_LOG_FILE" logCaptureFifo
      logCaptureSetEnvVar "LIBCAMERA_LOG_LEVELS" $ "*:" <> show libCameraSeverity
      loggerIO <- makeLoggerIO @"libcamera"
      logMsg @"cam" Info "Starting libcamera log capture"
      liftIO . forkIO . withFile logCaptureFifo ReadWriteMode $ \handle -> forever $ hGetLine handle >>= \logLine -> loggerIO (logCaptureLineSeverity logLine) logLine
    logCaptureDealloc = do
      logMsg @"cam" Info "Removing libcamera log capture FIFO"
      logCaptureClear
    -- Memory maps the camera's DMA buffer for frame access
    mapSize = CSize $ toEnum frameBufferLength
    mapFlags = mkMmapFlags mapShared mempty
    mapDmaBuffer = do
      logMsg @"cam" Info "Mapping DMA buffer"
      liftIO $ getDmaBufferFd >>= \dmaBufferFd -> mmap nullPtr mapSize protRead mapFlags dmaBufferFd 0
    unmapDmaBuffer dmaBuffer = do
      logMsg @"cam" Info "Unmapping DMA buffer"
      liftIO $ munmap dmaBuffer mapSize