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

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

import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar)
import Control.Monad (void)
import Effectful (Dispatch (Static), DispatchOf, Eff, IOE, liftIO, (:>))
import Effectful.Dispatch.Static
  ( SideEffects (WithSideEffects)
  , StaticRep
  , evalStaticRep
  , getStaticRep
  , unsafeEff_
  )
import Effectful.Resource (Resource, allocateEff, allocateEff_)
import Foreign.C.String (peekCString)
import Foreign.Ptr (freeHaskellFunPtr)
import Hsm.Cam.FFI
  ( initializeFFI
  , makeCallback
  , makeLogger
  , registerCallback
  , registerLogger
  , requestCapture
  , shutdownFFI
  )
import Hsm.Log (Log, Severity (Info, Trace), getLoggerIO, logMsg)

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

type instance DispatchOf Cam = Static WithSideEffects

newtype instance StaticRep Cam
  = Cam (MVar Int)

stillCapture :: (Log "cam" :> es, Cam :> es) => Eff es ()
stillCapture = do
  Cam fdVar <- getStaticRep
  logMsg Trace "Requesting still capture"
  fd <- unsafeEff_ $ requestCapture >> takeMVar fdVar
  logMsg Trace $ "Still capture data available in FD " <> show fd

runCam
  :: (IOE :> es, Log "cam" :> es, Resource :> es)
  => Eff (Cam : es) a
  -> Eff es a
runCam action = do
  fdVar <- liftIO newEmptyMVar
  void loggerBracket
  void $ requestCallbackBracket fdVar
  void ffiBracket
  evalStaticRep (Cam fdVar) action
  where
    loggerBracket = allocateEff loggerAlloc loggerDealloc
      where
        loggerAlloc = do
          logMsg Info "Registering FFI logger"
          loggerIO <- getLoggerIO
          loggerFFI <-
            liftIO . makeLogger $ \severity message ->
              peekCString message >>= loggerIO (toEnum severity)
          liftIO $ registerLogger loggerFFI
          return loggerFFI
        loggerDealloc loggerFFI = do
          logMsg Info "Unregistering FFI logger"
          liftIO $ freeHaskellFunPtr loggerFFI
    requestCallbackBracket fdVar =
      allocateEff requestCallbackAlloc requestCallbackDealloc
      where
        requestCallbackAlloc = do
          logMsg Info "Registering FFI callback"
          requestCallbackFFI <- liftIO . makeCallback $ putMVar fdVar
          liftIO $ registerCallback requestCallbackFFI
          return requestCallbackFFI
        requestCallbackDealloc requestCallbackFFI = do
          logMsg Info "Unregistering FFI callback"
          liftIO $ freeHaskellFunPtr requestCallbackFFI
    ffiBracket = allocateEff_ ffiAlloc ffiDealloc
      where
        ffiAlloc = liftIO initializeFFI
        ffiDealloc = liftIO shutdownFFI