summaryrefslogtreecommitdiff
path: root/src/Trivmix.hs
blob: 96e578b051191769641c8e62c143c3abccec6bd5 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
{-# 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.Posix.Types
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.IO

import System.FileLock
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"
    where
      x' = 20 * (logBase 10 x)

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 $ 10 ** (0.05 * f), rest)
        | otherwise = (Lin f, str)
        where
          prec = take lU str
          rest = drop lU str
          unit = "dB"
          lU = length unit

instance Eq Level where
  (Lin a) == (Lin b) = a == b
  (Lin a) == (DB b) = a == b
  (DB a) == (Lin b) = a == b
  (DB a) == (DB b) = a == b

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"
                                     )
                        )

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

initialLevel :: Level
initialLevel = Lin 0

defFileMode :: FileMode
defFileMode = foldl unionFileModes nullFileMode [ ownerReadMode
                                             , ownerWriteMode
                                             , groupReadMode
                                             , groupWriteMode
                                             , otherReadMode
                                             ]

defDirectoryMode :: FileMode
defDirectoryMode = foldl unionFileModes nullFileMode [ ownerModes
                                                  , groupModes
                                                  , otherReadMode
                                                  , otherExecuteMode
                                                  ]
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
  let withFiles = foldl (.) id $ map (\f -> onStateFile f (show initialLevel ++ "\n")) levelFiles
  withFiles $ 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) = x

handleFiles :: INotify -> MVar Level -> [FilePath] -> IO ()
handleFiles inotify level files = do
  initLevel <- readMVar level
  levelChanges <- (newChan :: IO (Chan Level))
  stderrLock <- newMVar) ()
  let 
    handleFile file = do
      levelChanges' <- dupChan levelChanges
      forkIO $ forever $ do -- Broadcast level changes and update all files
        readChan levelChanges' >>= writeLevel file stderrLock
      addWatch inotify watchedAttrs file (const $ readLevel levelChanges level file stderrLock)
  mapM handleFile 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
      directories = iterate takeDirectory directory
  createDirs <- takeWhileM (\d -> not <$> doesDirectoryExist d) directories
  exists <- doesFileExist file
  let acquireFile = case exists of
        True -> return ()
        False -> do
          hPutStrLn stderr $ "Creating ‘" ++ file ++ "’ (file)"
          createFile file defFileMode >>= closeFd >> writeFile file initial
      releaseFile = case exists of
        True -> return ()
        False -> do
          hPutStrLn stderr $ "Removing ‘" ++ file ++ "’ (file)"
          removeFile file
      acquireDir = (flip mapM) (reverse createDirs) $ \directory -> do
          hPutStrLn stderr $ "Creating ‘" ++ directory ++ "’ (dir)"
          createDirectory directory
          setFileMode directory defDirectoryMode
      releaseDir = (flip mapM) createDirs $ \directory -> do
          hPutStrLn stderr $ "Removing ‘" ++ directory ++ "’ (dir)"
          removeDirectory directory
      acquire = acquireDir >> acquireFile
      release = releaseFile >> releaseDir
  bracket_ acquire release action

takeWhileM :: Monad m => (a -> m Bool) -> [a] -> m [a]
takeWhileM _ [] = return []
takeWhileM pred (x:xs) = do
  take <- pred x
  case take of
    True -> do
      rest <- takeWhileM pred xs
      return $ x:rest
    False -> do
      return []

readLevel :: Chan Level -> MVar Level -> FilePath -> MVar () -> IO ()
readLevel levelChan current file stderrLock = catch action handler
  where
    action = do
      level <- withFileLock file Shared $ const $ readFile file >>= readIO . stripSpace
      oldLevel <- readMVar current
      when (oldLevel /= level) $ do
        writeChan levelChan level
        withMVarLock stderrLock $ 
          hPutStrLn stderr $ "Detected new level: " ++ (show level)
    handler e = if isUserError e
                then do
                  withMVarLock stderrLock $ 
                    hPutStrLn stderr $ "Could not parse new level from ‘" ++ file ++ "’ - overwriting."
                  readMVar current >>= writeLevel file stderrLock
                else throw e
    stripSpace = reverse . stripSpace' . reverse . stripSpace'
    stripSpace' [] = []
    stripSpace' l@(x:xs) = if isSpace x
                          then stripSpace' xs
                          else l

writeLevel :: FilePath -> MVar () -> Level -> IO ()
writeLevel file stderrLock level = withFileLock file Exclusive $ const $ do
  withMVarLock stderrLock $ 
    hPutStrLn stderr $ "Writing out level ‘" ++ (show level) ++ "’ to ‘" ++ file ++ "’"
  writeFile file (show level ++ "\n")

withMVarLock :: MVar () -> IO a -> IO a
withMVarLock lock = bracket_ (putMVar lock ()) (takeMVar lock)