Carabiner.hs

{-# OPTIONS_GHC -fno-warn-dodgy-imports -fno-warn-name-shadowing #-}
module Sound.Tidal.Carabiner where

{-
    Carabiner.hs - For syncing with the Link protocol over Carabiner.
    Copyright (C) 2020, 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/>.
-}

import Network.Socket hiding (send, sendTo, recv, recvFrom)
import Network.Socket.ByteString (send, recv)
import qualified Data.ByteString.Char8 as B8
import Control.Concurrent (forkIO, takeMVar, putMVar)
import qualified Sound.Tidal.Stream as S
import Sound.Tidal.Tempo
import System.Clock
import Text.Read (readMaybe)
import Control.Monad (when, forever)
import Data.Maybe (isJust, fromJust)
import qualified Sound.OSC.FD as O

carabiner :: S.Stream -> Int -> Double -> IO Socket
carabiner tidal bpc latency = do sock <- client tidal bpc latency "127.0.0.1" 17000
                                 sendMsg sock "status\n"
                                 return sock

client :: S.Stream -> Int -> Double -> String -> Int -> IO Socket
client tidal bpc latency host port = withSocketsDo $
                       do addrInfo <- getAddrInfo Nothing (Just host) (Just $ show port)
                          let serverAddr = head addrInfo
                          sock <- socket (addrFamily serverAddr) Stream defaultProtocol
                          connect sock (addrAddress serverAddr)
                          _ <- forkIO $ listener tidal bpc latency sock
                          -- sendMsg sock "status\n"
                          -- threadDelay 10000000
                          return sock

listener :: S.Stream -> Int -> Double -> Socket -> IO ()
listener tidal bpc latency sock =
  forever $ do rMsg <- recv sock 1024
               let msg = B8.unpack rMsg
                   (name:_:ws) = words msg
                   pairs = pairs' ws
                   pairs' (a:b:xs) = (a,b):(pairs' xs)
                   pairs' _ = []
               act tidal bpc latency name pairs

act :: S.Stream -> Int -> Double -> String -> [(String, String)] -> IO ()
act tidal bpc latency "status" pairs
  = do let start = (lookup ":start" pairs >>= readMaybe) :: Maybe Integer
           bpm   = (lookup ":bpm"   pairs >>= readMaybe) :: Maybe Double
           beat  = (lookup ":beat"  pairs >>= readMaybe) :: Maybe Double
       when (and [isJust start, isJust bpm, isJust beat]) $ do
         nowM <- getTime Monotonic
         nowO <- O.time
         let m = (fromIntegral $ sec nowM) + ((fromIntegral $ nsec nowM)/1000000000)
             d = nowO - m
             start' = ((fromIntegral $ fromJust start) / 1000000)
             startO = start' + d
             -- cyc = toRational $ (fromJust beat) / (fromIntegral bpc)
         tempo <- takeMVar (S.sTempoMV tidal)
         let tempo' = tempo {atTime = startO + latency,
                             atCycle = 0,
                             cps = ((fromJust bpm) / 60) / (fromIntegral bpc)
                            }
         putMVar (S.sTempoMV tidal) $ tempo'
act _ _ _ name _ = putStr $ "Unhandled thingie " ++ name

sendMsg :: Socket -> String -> IO ()
sendMsg sock msg = do _ <- send sock $ B8.pack msg
                      return ()