shrub/pkg/hs-urbit/lib/Vere/Ames.hs

module Vere.Ames (ames) where

import UrbitPrelude

import Arvo                      hiding (Fake)
import Network.Socket            hiding (recvFrom, sendTo)
import Network.Socket.ByteString
import Vere.Pier.Types

import Control.Concurrent (threadDelay)

import qualified Urbit.Time as Time


-- Types -----------------------------------------------------------------------

data AmesDrv = AmesDrv
  { aIsLive    :: IORef Bool
  , aSocket    :: Socket
  , aWakeTimer :: Async ()
  , aListener  :: Async ()
  }

data NetworkMode = Fake | Real
  deriving (Eq, Ord, Show)

{-
data GalaxyInfo = GalaxyInfo { ip :: Ipv4, age :: Time.Unix }
  deriving (Eq, Ord, Show)
-}


-- Utils -----------------------------------------------------------------------

galaxyPort :: NetworkMode -> Galaxy -> PortNumber
galaxyPort Fake (Galaxy g) = fromIntegral g + 31337
galaxyPort Real (Galaxy g) = fromIntegral g + 13337

listenPort :: NetworkMode -> Ship -> PortNumber
listenPort m s | s < 256 = galaxyPort m (fromIntegral s)
listenPort m _           = 0

localhost :: HostAddress
localhost = tupleToHostAddress (127,0,0,1)

okayFakeAddr :: AmesDest -> Bool
okayFakeAddr = \case
    ADGala _ _          -> True
    ADIpv4 _ p (Ipv4 a) -> a == localhost

destSockAddr :: NetworkMode -> AmesDest -> SockAddr
destSockAddr m = \case
    ADGala _ g   -> SockAddrInet (galaxyPort m g) localhost
    ADIpv4 _ p a -> SockAddrInet (fromIntegral p) (unIpv4 a)

barnEv :: KingInstance -> Ev
barnEv inst =
  EvBlip $ BlipEvNewt $ NewtEvBarn (fromIntegral inst, ()) ()

wakeEv :: Ev
wakeEv =
  EvBlip $ BlipEvAmes $ AmesEvWake () ()

hearEv :: Time.Wen -> PortNumber -> HostAddress -> ByteString -> Ev
hearEv w p a bs =
    EvBlip $ BlipEvAmes $ AmesEvHear () dest (MkBytes bs)
  where
    dest = ADIpv4 w (fromIntegral p) (Ipv4 a)

_turfText :: Turf -> Text
_turfText = intercalate "." . reverse . fmap unCord . unTurf


--------------------------------------------------------------------------------

{-
    inst      -- Process instance number.
    who       -- Which ship are we?
    enqueueEv -- Queue-event action.
    mPort     -- Explicit port override from command line arguments.

    We ignore the %turf arguments for now. We only have fake ships,
    so we don't implement the DNS stuff yet.

    TODO Handle socket exceptions in waitPacket

    4096 is a reasonable number for recvFrom. Packets of that size are
    not possible on the internet.

    TODO log when `sendTo` sent fewer bytes than requested.

    TODO verify that the KingInstances match on effects.
-}
ames :: KingInstance -> Ship -> Maybe Port -> QueueEv
     -> ([Ev], Acquire (EffCb NewtEf))
ames inst who mPort enqueueEv =
    (initialEvents, runAmes)
  where
    initialEvents :: [Ev]
    initialEvents = [barnEv inst]

    runAmes :: Acquire (EffCb NewtEf)
    runAmes = do
        drv <- mkAcquire start stop
        pure (handleEffect drv)

    start :: IO AmesDrv
    start = do
        vLiv <- newIORef False
        time <- async runTimer
        sock <- bindSock
        hear <- async (waitPacket sock)
        pure $ AmesDrv vLiv sock time hear

    netMode :: NetworkMode
    netMode = Fake

    stop :: AmesDrv -> IO ()
    stop (AmesDrv{..}) = do
        cancel aWakeTimer
        cancel aListener
        close' aSocket

    runTimer :: IO ()
    runTimer = forever $ do
        threadDelay (300 * 1000000) -- 300 seconds
        atomically (enqueueEv wakeEv)

    bindSock :: IO Socket
    bindSock = do
        let ourPort = maybe (listenPort netMode who) fromIntegral mPort
        s  <- socket AF_INET Datagram defaultProtocol
        () <- bind s (SockAddrInet ourPort localhost)
        pure s

    waitPacket :: Socket -> IO ()
    waitPacket s = forever $ do
        (bs, addr) <- recvFrom s 4096
        wen        <- Time.now
        case addr of
            SockAddrInet p a -> atomically (enqueueEv $ hearEv wen p a bs)
            _                -> pure ()

    handleEffect :: AmesDrv -> NewtEf -> IO ()
    handleEffect AmesDrv{..} = \case
      NewtEfTurf (_id, ()) turfs -> do
          writeIORef aIsLive True

      NewtEfSend (_id, ()) dest (MkBytes bs) -> do
          live <- readIORef aIsLive
          when live $ do
              when (netMode == Real || okayFakeAddr dest) $ do
                  void $ sendTo aSocket bs $ destSockAddr netMode dest