{-# LANGUAGE RecordWildCards #-}

import Foreign.C.Types (CFloat(..))
import qualified Sound.JACK as Jack
import qualified Sound.JACK.Audio as Audio

import Options.Applicative

import Data.Maybe

import System.Directory
import System.FilePath
import System.Posix.Files
import System.Posix.IO
import System.Environment
import System.Process

import Control.Concurrent
import Control.Concurrent.MVar
import Control.Concurrent.Chan

import qualified Control.Monad.Trans.Class as Trans
import qualified Control.Monad.Exception.Synchronous as Sync

import Control.Exception
import System.IO.Error

import System.INotify

import Data.Char
import Data.Function

import Control.Monad
  
import           Data.CaseInsensitive  ( CI )
import qualified Data.CaseInsensitive as CI

data Options = Options
               { input :: String
               , output :: String
               , client :: String
               , run :: Maybe String
               , levelFiles :: [FilePath]
               }

data Level = Lin Float | DB Float

instance Show Level where
  show (Lin x) = show x
  show (DB x) = (show x) ++ "dB"

instance Read Level where
  readsPrec i = map toL . readsPrec i
    where
      toL :: (Float, String) -> (Level, String)
      toL (f, str)
        | ((==) `on` CI.mk) prec unit = (DB f, rest)
        | otherwise = (Lin f, str)
        where
          prec = take lU str
          rest = drop lU str
          unit = "dB"
          lU = length unit

optionParser :: Parser Options
optionParser = Options <$>
               (fromMaybe "in" <$> optional (strOption ( long "input"
                                                         <> metavar "STRING"
                                                       )
                                            )
               )
               <*> (fromMaybe "out" <$> optional (strOption ( long "output"
                                                              <> metavar "STRING"
                                                            )
                                                 )
                   )
               <*> strOption ( long "client"
                               <> metavar "STRING"
                             )
               <*> optional ( strOption ( long "run"
                                          <> metavar "FILE"
                                        )
                            )
               <*> some (strArgument ( metavar "FILE..."
                                       <> help "Files that contain levels to assume and synchronize"
                                     )
                        )

initialLevel :: Level
initialLevel = Lin 0

watchedAttrs :: [EventVariety]
watchedAttrs = [ Modify
               , Move
               , MoveIn
               , MoveOut
               , MoveSelf
               , Create
               , Delete
               , DeleteSelf
               ]

main :: IO ()
main = execParser opts >>= trivmix
  where
    opts = info (helper <*> optionParser)
           ( fullDesc
             <> progDesc "Setup a JACK mixing input/output pair controlled by fifos in a state directory"
             <> header "Trivmix - A trivial mixer"
           )

trivmix :: Options -> IO ()
trivmix Options{..} = do
  level <- newMVar initialLevel
  withINotify $ \inotify -> do
    handleFiles inotify level levelFiles
    Jack.handleExceptions $
      Jack.withClientDefault client $ \client' ->
      Jack.withPort client' input $ \input' ->
      Jack.withPort client' output $ \output' -> do
        Trans.lift $ do
          case run of
            Nothing -> return ()
            Just run' -> do
              (_, _, _, ph) <- createProcess $ (proc run' [client ++ ":" ++ input, client ++ ":" ++ output]) { delegate_ctlc = True }
              return ()
        Audio.withProcessMono client' input' (mix level) output' $
          Jack.withActivation client' $ Trans.lift Jack.waitForBreak

mix :: MVar Level -> CFloat -> IO CFloat
mix level input = do
  level' <- readMVar level
  return $ (CFloat $ toFloat level') * input
  where
    toFloat (Lin x) = x
    toFloat (DB x) = 10 ** (0.05 * x)

handleFiles :: INotify -> MVar Level -> [FilePath] -> IO ()
handleFiles inotify level files = do
  initLevel <- readMVar level
  levelChanges <- (newChan :: IO (Chan Level))
  let 
    handleFile file = do
      levelChanges' <- dupChan levelChanges
      forkIO $ forever $ do -- Broadcast level changes and update all files
        readChan levelChanges' >>= writeLevel file
      addWatch inotify watchedAttrs file (const $ readLevel levelChanges level file)
  sequence [onStateFile f (show initLevel ++ "\n") handleFile f | f <- files]
  forkIO $ forever $ do
    readChan levelChanges >>= swapMVar level
    return ()
  return ()

onStateFile :: FilePath -> String -> IO a -> IO a
onStateFile file initial action = do
  let directory = takeDirectory file
  dirExists <- doesDirectoryExist directory
  exists <- doesFileExist file
  createDirectoryIfMissing True directory
  let acquireFile = case exists of
        True -> return ()
        False -> createFile file fileMode >>= closeFd >> writeFile file initial
      fileMode = foldl unionFileModes nullFileMode [ ownerReadMode
                                                   , ownerWriteMode
                                                   , groupReadMode
                                                   , groupWriteMode
                                                   ]
      releaseFile = case exists of
        True -> return ()
        False -> removeFile file
      releaseDir = case dirExists of
        True -> return ()
        False -> removeDirectory directory
      acquire = acquireFile
      release = releaseFile >> releaseDir
  bracket_ acquire release action

readLevel :: Chan Level -> MVar Level -> FilePath -> IO ()
readLevel levelChan current file = catch action handler
  where
    action = readFile file >>= readIO . stripSpace >>= writeChan levelChan
    handler e = if isUserError e
                then readMVar current >>= writeLevel file
                else throw e
    stripSpace = reverse . stripSpace' . reverse . stripSpace'
    stripSpace' [] = []
    stripSpace' l@(x:xs) = if isSpace x
                          then stripSpace' xs
                          else l

writeLevel :: FilePath -> Level -> IO ()
writeLevel file level = writeFile file (show level ++ "\n")