module Tempo where
import Data.Time (getCurrentTime, UTCTime, diffUTCTime)
import Data.Time.Clock.POSIX
import Control.Monad (forM_, forever)
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.MVar
import Control.Monad.Trans (liftIO)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Network.WebSockets as WS
import qualified Control.Exception as E
import qualified System.IO.Error as Error
import GHC.Conc.Sync (ThreadId)
import System.Environment (getEnv)
import Utils
data Tempo = Tempo {at :: UTCTime, beat :: Double, bps :: Double}
type Client = WS.Sink WS.Hybi00
type ClientState = [Client]
instance Show Tempo where
show x = show (at x) ++ "," ++ show (beat x) ++ "," ++ show (bps x)
getClockIp :: IO (String)
getClockIp = do addr <- E.try (getEnv "TEMPO_ADDR")
return $ either (const "127.0.0.1") (id) (addr :: Either E.IOException String)
readTempo :: String -> Tempo
readTempo x = Tempo (read a) (read b) (read c)
where (a:b:c:_) = wordsBy (== ',') x
logicalTime :: Tempo -> Double -> Double
logicalTime t b = changeT + timeDelta
where beatDelta = b (beat t)
timeDelta = beatDelta / (bps t)
changeT = realToFrac $ utcTimeToPOSIXSeconds $ at t
tempoMVar :: IO (MVar (Tempo))
tempoMVar = do now <- getCurrentTime
mv <- newMVar (Tempo now 0 (126/60))
forkIO $ clocked $ f mv
return mv
where f mv change _ = do swapMVar mv change
return ()
beatNow :: Tempo -> IO (Double)
beatNow t = do now <- getCurrentTime
let delta = realToFrac $ diffUTCTime now (at t)
let beatDelta = bps t * delta
return $ beat t + beatDelta
clientApp :: MVar Tempo -> MVar Double -> WS.WebSockets WS.Hybi10 ()
clientApp mTempo mBps = do
sink <- WS.getSink
liftIO $ forkIO $ sendBps sink mBps
forever loop
where
loop = do
msg <- WS.receiveData
let tempo = readTempo $ T.unpack msg
liftIO $ tryTakeMVar mTempo
liftIO $ putMVar mTempo tempo
sendBps :: (WS.TextProtocol p) => WS.Sink p -> MVar Double -> IO ()
sendBps sink mBps = forever $ do
bps <- takeMVar mBps
WS.sendSink sink $ WS.textData $ T.pack $ show bps
connectClient clockip mTempo mBps = do
E.handle
((\err ->
do putStrLn "Couldn't connect to tempo clock, starting local clock.."
startServer
threadDelay 500000
cx "127.0.0.1"
) :: E.SomeException -> IO ())
(cx clockip)
where cx ip = WS.connect ip 9160 "/tempo" (clientApp mTempo mBps)
runClient :: IO ((MVar Tempo, MVar Double))
runClient =
do clockip <- getClockIp
mTempo <- newEmptyMVar
mBps <- newEmptyMVar
forkIO $ connectClient clockip mTempo mBps
return (mTempo, mBps)
bpsSetter :: IO (Double -> IO ())
bpsSetter = do (_, mBps) <- runClient
return $ (\b -> putMVar mBps b)
clocked :: (Tempo -> Int -> IO ()) -> IO ()
clocked callback =
do (mTempo, mBps) <- runClient
t <- readMVar mTempo
now <- getCurrentTime
let delta = realToFrac $ diffUTCTime now (at t)
beatDelta = bps t * delta
nowBeat = beat t + beatDelta
nextBeat = ceiling nowBeat
loop mTempo nextBeat
where loop mTempo b =
do t <- readMVar mTempo
now <- getCurrentTime
let delta = realToFrac $ diffUTCTime now (at t)
actualBeat = (beat t) + ((bps t) * delta)
beatDelta = (fromIntegral b) actualBeat
delay = beatDelta / (bps t)
threadDelay $ floor (delay * 1000000)
callback t b
loop mTempo $ b + 1
clockedTick :: Int -> (Tempo -> Int -> IO ()) -> IO ()
clockedTick tpb callback =
do (mTempo, mBps) <- runClient
t <- readMVar mTempo
now <- getCurrentTime
let delta = realToFrac $ diffUTCTime now (at t)
beatDelta = bps t * delta
nowBeat = beat t + beatDelta
nextTick = ceiling (nowBeat * (fromIntegral tpb))
loop mTempo nextTick
where loop mTempo tick =
do t <- readMVar mTempo
now <- getCurrentTime
let tps = (fromIntegral tpb) * bps t
delta = realToFrac $ diffUTCTime now (at t)
actualTick = ((fromIntegral tpb) * beat t) + (tps * delta)
tickDelta = (fromIntegral tick) actualTick
delay = tickDelta / tps
threadDelay $ floor (delay * 1000000)
callback t tick
loop mTempo $ tick + 1
updateTempo :: MVar Tempo -> Maybe Double -> IO ()
updateTempo mt Nothing = return ()
updateTempo mt (Just bps') = do t <- takeMVar mt
now <- getCurrentTime
let delta = realToFrac $ diffUTCTime now (at t)
beat' = (beat t) + ((bps t) * delta)
putMVar mt $ Tempo now beat' bps'
addClient :: Client -> ClientState -> ClientState
addClient client clients = client : clients
removeClient :: Client -> ClientState -> ClientState
removeClient client = filter (/= client)
broadcast :: Text -> ClientState -> IO ()
broadcast message clients = do
T.putStrLn message
forM_ clients $ \sink -> WS.sendSink sink $ WS.textData message
startServer :: IO (ThreadId)
startServer = do
start <- getCurrentTime
tempoState <- newMVar (Tempo start 0 1)
clientState <- newMVar []
forkIO $ WS.runServer "0.0.0.0" 9160 $ serverApp tempoState clientState
serverApp :: MVar Tempo -> MVar ClientState -> WS.Request -> WS.WebSockets WS.Hybi00 ()
serverApp tempoState clientState rq = do
WS.acceptRequest rq
sink <- WS.getSink
tempo <- liftIO $ readMVar tempoState
liftIO $ WS.sendSink sink $ WS.textData $ T.pack $ show tempo
clients <- liftIO $ readMVar clientState
liftIO $ modifyMVar_ clientState $ \s -> return $ addClient sink s
serverLoop tempoState clientState sink
serverLoop :: WS.Protocol p => MVar Tempo -> MVar ClientState -> Client -> WS.WebSockets p ()
serverLoop tempoState clientState client = flip WS.catchWsError catchDisconnect $
forever $ do
msg <- WS.receiveData
liftIO $ updateTempo tempoState $ maybeRead $ T.unpack msg
tempo <- liftIO $ readMVar tempoState
liftIO $ readMVar clientState >>= broadcast (T.pack $ show tempo)
where
catchDisconnect e = case E.fromException e of
Just WS.ConnectionClosed -> liftIO $ modifyMVar_ clientState $ \s -> do
let s' = removeClient client s
return s'
_ -> return ()