path: root/src/Network.hs

module Network (
    Peer(..),
    PeerAddress(..),
    startServer,
    sendToPeer,
) where

import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.Except

import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M
import qualified Data.Text as T

import Network.Socket
import Network.Socket.ByteString (recvFrom, sendTo)

import Channel
import Identity
import PubKey
import Storage


discoveryPort :: ServiceName
discoveryPort = "29665"


data Peer = Peer
    { peerAddress :: PeerAddress
    , peerIdentity :: Maybe (Stored Identity)
    , peerChannels :: [Channel]
    , peerSocket :: Socket
    , peerStorage :: Storage
    , peerInStorage :: PartialStorage
    }
    deriving (Show)

data PeerAddress = DatagramAddress SockAddr
    deriving (Show)


data TransportHeader = AnnouncePacket PartialRef
                     | IdentityRequest PartialRef PartialRef
                     | IdentityResponse PartialRef
                     | TrChannelRequest PartialRef
                     | TrChannelAccept PartialRef

data ServiceHeader = ServiceHeader T.Text PartialRef

transportToObject :: TransportHeader -> PartialObject
transportToObject = \case
    AnnouncePacket ref -> Rec
        [ (BC.pack "TRANS", RecText $ T.pack "announce")
        , (BC.pack "identity", RecRef ref)
        ]
    IdentityRequest ref from -> Rec
        [ (BC.pack "TRANS", RecText $ T.pack "idreq")
        , (BC.pack "identity", RecRef ref)
        , (BC.pack "from", RecRef from)
        ]
    IdentityResponse ref -> Rec
        [ (BC.pack "TRANS", RecText $ T.pack "idresp")
        , (BC.pack "identity", RecRef ref)
        ]
    TrChannelRequest ref -> Rec
        [ (BC.pack "TRANS", RecText $ T.pack "chreq")
        , (BC.pack "req", RecRef ref)
        ]
    TrChannelAccept ref -> Rec
        [ (BC.pack "TRANS", RecText $ T.pack "chacc")
        , (BC.pack "acc", RecRef ref)
        ]

transportFromObject :: PartialObject -> Maybe TransportHeader
transportFromObject (Rec items)
    | Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "announce"
    , Just (RecRef ref) <- lookup (BC.pack "identity") items
    = Just $ AnnouncePacket ref

    | Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "idreq"
    , Just (RecRef ref) <- lookup (BC.pack "identity") items
    , Just (RecRef from) <- lookup (BC.pack "from") items
    = Just $ IdentityRequest ref from

    | Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "idresp"
    , Just (RecRef ref) <- lookup (BC.pack "identity") items
    = Just $ IdentityResponse ref

    | Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "chreq"
    , Just (RecRef ref) <- lookup (BC.pack "req") items
    = Just $ TrChannelRequest ref

    | Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "chacc"
    , Just (RecRef ref) <- lookup (BC.pack "acc") items
    = Just $ TrChannelAccept ref

transportFromObject _ = Nothing

serviceToObject :: ServiceHeader -> PartialObject
serviceToObject (ServiceHeader svc ref) = Rec
        [ (BC.pack "SVC", RecText svc)
        , (BC.pack "ref", RecRef ref)
        ]

serviceFromObject :: PartialObject -> Maybe ServiceHeader
serviceFromObject (Rec items)
    | Just (RecText svc) <- lookup (BC.pack "SVC") items
    , Just (RecRef ref) <- lookup (BC.pack "ref") items
    = Just $ ServiceHeader svc ref
serviceFromObject _ = Nothing


startServer :: (String -> IO ()) -> String -> Stored Identity -> IO (Chan Peer, Chan (Peer, T.Text, Ref))
startServer logd bhost sidentity = do
    chanPeer <- newChan
    chanSvc <- newChan
    peers <- newMVar M.empty

    let open addr = do
            sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
            setSocketOption sock ReuseAddr 1
            setSocketOption sock Broadcast 1
            setCloseOnExecIfNeeded =<< fdSocket sock
            bind sock (addrAddress addr)
            return sock

        loop sock = do
            st <- derivePartialStorage $ storedStorage sidentity
            baddr:_ <- getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just bhost) (Just discoveryPort)
            void $ sendTo sock (BL.toStrict $ serializeObject $ transportToObject $ AnnouncePacket $ partialRef st $ storedRef sidentity) (addrAddress baddr)
            forever $ do
                (msg, paddr) <- recvFrom sock 4096
                mbpeer <- M.lookup paddr <$> readMVar peers
                if | Just peer <- mbpeer
                   , ch:_ <- peerChannels peer
                   , Just plain <- channelDecrypt ch msg
                   , Right (obj:objs) <- runExcept $ deserializeObjects (peerInStorage peer) $ BL.fromStrict plain
                   , Just (ServiceHeader svc ref) <- serviceFromObject obj
                   -> do forM_ objs $ storeObject $ peerInStorage peer
                         copyRef (peerStorage peer) ref >>= \case
                             Just pref -> writeChan chanSvc (peer, svc, pref)
                             Nothing   -> logd $ show paddr ++ ": incomplete service packet"

                   | otherwise -> do
                       (pst, ist) <- case mbpeer of
                                          Just peer -> return (peerStorage peer, peerInStorage peer)
                                          Nothing   -> do pst <- deriveEphemeralStorage $ storedStorage sidentity
                                                          ist <- derivePartialStorage pst
                                                          return (pst, ist)
                       if | Right (obj:objs) <- runExcept $ deserializeObjects ist $ BL.fromStrict msg
                          , Just tpack <- transportFromObject obj
                          -> packet sock paddr tpack objs pst ist

                          | otherwise -> logd $ show paddr ++ ": invalid packet"

        packet sock paddr (AnnouncePacket ref) _ _ ist = do
            logd $ "Got announce: " ++ show ref ++ " from " ++ show paddr
            when (refDigest ref /= refDigest (storedRef sidentity)) $ void $ sendTo sock (BL.toStrict $ BL.concat
                [ serializeObject $ transportToObject $ IdentityRequest ref (partialRef ist $ storedRef sidentity)
                , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
                ]) paddr

        packet _ paddr (IdentityRequest ref from) [] _ _ = do
            logd $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr ++ " without content"

        packet sock paddr (IdentityRequest ref from) (obj:objs) pst ist = do
            logd $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr
            logd $ show (obj:objs)
            from' <- storeObject ist obj
            if from == from'
               then do forM_ objs $ storeObject ist
                       copyRef pst from >>= \case
                           Nothing -> logd $ "Incomplete peer identity"
                           Just sfrom -> do
                               let peer = Peer (DatagramAddress paddr) (Just $ wrappedLoad sfrom) [] sock pst ist
                               modifyMVar_ peers $ return . M.insert paddr peer
                               writeChan chanPeer peer
                               void $ sendTo sock (BL.toStrict $ BL.concat
                                   [ serializeObject $ transportToObject $ IdentityResponse (partialRef ist $ storedRef sidentity)
                                   , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
                                   ]) paddr
               else logd $ "Mismatched content"

        packet _ paddr (IdentityResponse ref) [] _ _ = do
            logd $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr ++ " without content"

        packet sock paddr (IdentityResponse ref) (obj:objs) pst ist = do
            logd $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr
            logd $ show (obj:objs)
            ref' <- storeObject ist obj
            if ref == ref'
               then do forM_ objs $ storeObject ist
                       copyRef pst ref >>= \case
                           Nothing -> logd $ "Incomplete peer identity"
                           Just sref -> do
                               let pidentity = wrappedLoad sref
                                   peer = Peer (DatagramAddress paddr) (Just pidentity) [] sock pst ist
                               modifyMVar_ peers $ return . M.insert paddr peer
                               writeChan chanPeer peer
                               req <- createChannelRequest pst sidentity pidentity
                               void $ sendTo sock (BL.toStrict $ BL.concat
                                   [ serializeObject $ transportToObject $ TrChannelRequest (partialRef ist $ storedRef req)
                                   , lazyLoadBytes $ storedRef req
                                   , lazyLoadBytes $ storedRef $ signedData $ fromStored req
                                   , lazyLoadBytes $ storedRef $ crKey $ fromStored $ signedData $ fromStored req
                                   , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored req
                                   ]) paddr
               else logd $ "Mismatched content"

        packet _ paddr (TrChannelRequest _) [] _ _ = do
            logd $ "Got channel request: from " ++ show paddr ++ " without content"

        packet sock paddr (TrChannelRequest ref) (obj:objs) pst ist = do
            logd $ "Got channel request: from " ++ show paddr
            logd $ show (obj:objs)
            ref' <- storeObject ist obj
            if ref == ref'
               then do forM_ objs $ storeObject ist
                       copyRef pst ref >>= \case
                           Nothing -> logd $ "Incomplete channel request"
                           Just sref -> do
                               let request = wrappedLoad sref :: Stored ChannelRequest
                               modifyMVar_ peers $ \pval -> case M.lookup paddr pval of
                                   Just peer | Just pid <- peerIdentity peer ->
                                       runExceptT (acceptChannelRequest sidentity pid request) >>= \case
                                           Left errs -> do mapM_ logd ("Invalid channel request" : errs)
                                                           return pval
                                           Right (acc, channel) -> do
                                               logd $ "Got channel: " ++ show (storedRef channel)
                                               let peer' = peer { peerChannels = fromStored channel : peerChannels peer }
                                               writeChan chanPeer peer'
                                               void $ sendTo sock (BL.toStrict $ BL.concat
                                                   [ serializeObject $ transportToObject $ TrChannelAccept (partialRef ist $ storedRef acc)
                                                   , lazyLoadBytes $ storedRef acc
                                                   , lazyLoadBytes $ storedRef $ signedData $ fromStored acc
                                                   , lazyLoadBytes $ storedRef $ caKey $ fromStored $ signedData $ fromStored acc
                                                   , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored acc
                                                   ]) paddr
                                               return $ M.insert paddr peer' pval

                                   _ -> do logd $ "Invalid channel request - no peer identity"
                                           return pval
               else logd $ "Mismatched content"

        packet _ paddr (TrChannelAccept _) [] _ _ = do
            logd $ "Got channel accept: from " ++ show paddr ++ " without content"

        packet _ paddr (TrChannelAccept ref) (obj:objs) pst ist = do
            logd $ "Got channel accept: from " ++ show paddr
            logd $ show (obj:objs)
            ref' <- storeObject ist obj
            if ref == ref'
               then do forM_ objs $ storeObject ist
                       copyRef pst ref >>= \case
                           Nothing -> logd $ "Incomplete channel accept"
                           Just sref -> do
                               let accepted = wrappedLoad sref :: Stored ChannelAccept
                               modifyMVar_ peers $ \pval -> case M.lookup paddr pval of
                                   Just peer | Just pid <- peerIdentity peer ->
                                       runExceptT (acceptedChannel sidentity pid accepted) >>= \case
                                           Left errs -> do mapM_ logd ("Invalid channel accept" : errs)
                                                           return pval
                                           Right channel -> do
                                               logd $ "Got channel: " ++ show (storedRef channel)
                                               let peer' = peer { peerChannels = fromStored channel : peerChannels peer }
                                               writeChan chanPeer peer'
                                               return $ M.insert paddr peer' pval
                                   _ -> do logd $ "Invalid channel accept - no peer identity"
                                           return pval

               else logd $ "Mismatched content"

    void $ forkIO $ withSocketsDo $ do
        let hints = defaultHints
              { addrFlags = [AI_PASSIVE]
              , addrSocketType = Datagram
              }
        addr:_ <- getAddrInfo (Just hints) Nothing (Just discoveryPort)
        bracket (open addr) close loop

    return (chanPeer, chanSvc)


sendToPeer :: Storable a => Stored Identity -> Peer -> T.Text -> a -> IO ()
sendToPeer _ peer@Peer { peerChannels = ch:_ } svc obj = do
    let st = peerInStorage peer
    ref <- store st obj
    Just bytes <- return $ lazyLoadBytes ref
    let plain = BL.toStrict $ BL.concat
            [ serializeObject $ serviceToObject $ ServiceHeader svc ref
            , bytes
            ]
    ctext <- channelEncrypt ch plain
    let DatagramAddress paddr = peerAddress peer
    void $ sendTo (peerSocket peer) ctext paddr

sendToPeer _ _ _ _ = putStrLn $ "No channel to peer"