module Sound.Tidal.Stream.Listen where

import Control.Concurrent.MVar
import qualified Control.Exception as E
import Control.Monad (when)
import qualified Data.Map as Map
import Data.Maybe (fromJust)
import qualified Network.Socket as N
import qualified Sound.Osc.Fd as O
import qualified Sound.Osc.Transport.Fd.Udp as O
import Sound.Tidal.Config
import Sound.Tidal.ID
import Sound.Tidal.Pattern
import Sound.Tidal.Stream.Types
import Sound.Tidal.Stream.UI
import System.IO (hPutStrLn, stderr)

{-
    Listen.hs - logic for listening and acting on incoming OSC messages
    Copyright (C) 2025, Alex McLean and contributors

    This library is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this library.  If not, see <http://www.gnu.org/licenses/>.
-}

openListener :: Config -> IO (Maybe O.Udp)
openListener :: Config -> IO (Maybe Udp)
openListener Config
c
  | Config -> Bool
cCtrlListen Config
c =
      IO (Maybe Udp)
-> (SomeException -> IO (Maybe Udp)) -> IO (Maybe Udp)
forall a. IO a -> (SomeException -> IO a) -> IO a
catchAny
        IO (Maybe Udp)
run
        ( \SomeException
_ -> do
            Config -> String -> IO ()
verbose Config
c String
"That port isn't available, perhaps another Tidal instance is already listening on that port?"
            Maybe Udp -> IO (Maybe Udp)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Udp
forall a. Maybe a
Nothing
        )
  | Bool
otherwise = Maybe Udp -> IO (Maybe Udp)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Udp
forall a. Maybe a
Nothing
  where
    run :: IO (Maybe Udp)
run = do
      Udp
sock <- String -> Int -> IO Udp
O.udpServer (Config -> String
cCtrlAddr Config
c) (Config -> Int
cCtrlPort Config
c)
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
cCtrlBroadcast Config
c) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Socket -> SocketOption -> Int -> IO ()
N.setSocketOption (Udp -> Socket
O.udpSocket Udp
sock) SocketOption
N.Broadcast Int
1
      Maybe Udp -> IO (Maybe Udp)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Udp -> IO (Maybe Udp)) -> Maybe Udp -> IO (Maybe Udp)
forall a b. (a -> b) -> a -> b
$ Udp -> Maybe Udp
forall a. a -> Maybe a
Just Udp
sock
    catchAny :: IO a -> (E.SomeException -> IO a) -> IO a
    catchAny :: forall a. IO a -> (SomeException -> IO a) -> IO a
catchAny = IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch

-- Listen to and act on OSC control messages
ctrlResponder :: Config -> Stream -> IO ()
ctrlResponder :: Config -> Stream -> IO ()
ctrlResponder Config
_ (stream :: Stream
stream@(Stream {sListen :: Stream -> Maybe Udp
sListen = Just Udp
sock})) = IO ()
loop
  where
    loop :: IO ()
    loop :: IO ()
loop = do
      Udp -> IO [Message]
forall t. Transport t => t -> IO [Message]
O.recvMessages Udp
sock IO [Message] -> ([Message] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Message -> IO ()) -> [Message] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Message -> IO ()
act
      IO ()
loop
    -- External controller commands
    act :: O.Message -> IO ()
    act :: Message -> IO ()
act (O.Message String
"/ctrl" (O.Int32 Int32
k : Datum
v : [])) =
      Message -> IO ()
act (String -> [Datum] -> Message
O.Message String
"/ctrl" [String -> Datum
O.string (String -> Datum) -> String -> Datum
forall a b. (a -> b) -> a -> b
$ Int32 -> String
forall a. Show a => a -> String
show Int32
k, Datum
v])
    act (O.Message String
"/ctrl" (O.AsciiString Ascii
k : v :: Datum
v@(O.Float Float
_) : [])) =
      String -> Value -> IO ()
add (Ascii -> String
O.ascii_to_string Ascii
k) (Double -> Value
VF (Maybe Double -> Double
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Double -> Double) -> Maybe Double -> Double
forall a b. (a -> b) -> a -> b
$ Datum -> Maybe Double
forall n. Floating n => Datum -> Maybe n
O.datum_floating Datum
v))
    act (O.Message String
"/ctrl" (O.AsciiString Ascii
k : O.AsciiString Ascii
v : [])) =
      String -> Value -> IO ()
add (Ascii -> String
O.ascii_to_string Ascii
k) (String -> Value
VS (Ascii -> String
O.ascii_to_string Ascii
v))
    act (O.Message String
"/ctrl" (O.AsciiString Ascii
k : O.Int32 Int32
v : [])) =
      String -> Value -> IO ()
add (Ascii -> String
O.ascii_to_string Ascii
k) (Int -> Value
VI (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
v))
    -- Stream playback commands
    act (O.Message String
"/mute" (Datum
k : [])) =
      Datum -> (ID -> IO ()) -> IO ()
withID Datum
k ((ID -> IO ()) -> IO ()) -> (ID -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Stream -> ID -> IO ()
streamMute Stream
stream
    act (O.Message String
"/unmute" (Datum
k : [])) =
      Datum -> (ID -> IO ()) -> IO ()
withID Datum
k ((ID -> IO ()) -> IO ()) -> (ID -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Stream -> ID -> IO ()
streamUnmute Stream
stream
    act (O.Message String
"/solo" (Datum
k : [])) =
      Datum -> (ID -> IO ()) -> IO ()
withID Datum
k ((ID -> IO ()) -> IO ()) -> (ID -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Stream -> ID -> IO ()
streamSolo Stream
stream
    act (O.Message String
"/unsolo" (Datum
k : [])) =
      Datum -> (ID -> IO ()) -> IO ()
withID Datum
k ((ID -> IO ()) -> IO ()) -> (ID -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Stream -> ID -> IO ()
streamUnsolo Stream
stream
    act (O.Message String
"/muteAll" []) =
      Stream -> IO ()
streamMuteAll Stream
stream
    act (O.Message String
"/unmuteAll" []) =
      Stream -> IO ()
streamUnmuteAll Stream
stream
    act (O.Message String
"/unsoloAll" []) =
      Stream -> IO ()
streamUnsoloAll Stream
stream
    act (O.Message String
"/hush" []) =
      Stream -> IO ()
streamHush Stream
stream
    act (O.Message String
"/silence" (Datum
k : [])) =
      Datum -> (ID -> IO ()) -> IO ()
withID Datum
k ((ID -> IO ()) -> IO ()) -> (ID -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Stream -> ID -> IO ()
streamSilence Stream
stream
    -- Cycle properties commands
    act (O.Message String
"/setcps" [O.Float Float
k]) =
      Stream -> Time -> IO ()
streamSetCPS Stream
stream (Time -> IO ()) -> Time -> IO ()
forall a b. (a -> b) -> a -> b
$ Float -> Time
forall a. Real a => a -> Time
toTime Float
k
    act (O.Message String
"/setbpm" [O.Float Float
k]) =
      Stream -> Time -> IO ()
streamSetBPM Stream
stream (Time -> IO ()) -> Time -> IO ()
forall a b. (a -> b) -> a -> b
$ Float -> Time
forall a. Real a => a -> Time
toTime Float
k
    act (O.Message String
"/setCycle" [O.Float Float
k]) =
      Stream -> Time -> IO ()
streamSetCycle Stream
stream (Time -> IO ()) -> Time -> IO ()
forall a b. (a -> b) -> a -> b
$ Float -> Time
forall a. Real a => a -> Time
toTime Float
k
    act (O.Message String
"/resetCycles" [Datum]
_) =
      Stream -> IO ()
streamResetCycles Stream
stream
    -- Nudge all command
    act (O.Message String
"/nudgeAll" [O.Double Double
k]) =
      Stream -> Double -> IO ()
streamNudgeAll Stream
stream Double
k
    act Message
m = Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Unhandled OSC: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Message -> String
forall a. Show a => a -> String
show Message
m
    add :: String -> Value -> IO ()
    add :: String -> Value -> IO ()
add String
k Value
v = do
      ValueMap
sMap <- MVar ValueMap -> IO ValueMap
forall a. MVar a -> IO a
takeMVar (Stream -> MVar ValueMap
sStateMV Stream
stream)
      MVar ValueMap -> ValueMap -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (Stream -> MVar ValueMap
sStateMV Stream
stream) (ValueMap -> IO ()) -> ValueMap -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Value -> ValueMap -> ValueMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
k Value
v ValueMap
sMap
      () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    withID :: O.Datum -> (ID -> IO ()) -> IO ()
    withID :: Datum -> (ID -> IO ()) -> IO ()
withID (O.AsciiString Ascii
k) ID -> IO ()
func = ID -> IO ()
func (ID -> IO ()) -> ID -> IO ()
forall a b. (a -> b) -> a -> b
$ (String -> ID
ID (String -> ID) -> (Ascii -> String) -> Ascii -> ID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ascii -> String
O.ascii_to_string) Ascii
k
    withID (O.Int32 Int32
k) ID -> IO ()
func = ID -> IO ()
func (ID -> IO ()) -> ID -> IO ()
forall a b. (a -> b) -> a -> b
$ (String -> ID
ID (String -> ID) -> (Int32 -> String) -> Int32 -> ID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> String
forall a. Show a => a -> String
show) Int32
k
    withID Datum
_ ID -> IO ()
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ctrlResponder Config
_ Stream
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()