diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Attach.hs | 57 | ||||
| -rw-r--r-- | src/Main.hs | 7 | ||||
| -rw-r--r-- | src/Message/Service.hs | 26 | ||||
| -rw-r--r-- | src/Network.hs | 52 | ||||
| -rw-r--r-- | src/Service.hs | 62 |
5 files changed, 126 insertions, 78 deletions
diff --git a/src/Attach.hs b/src/Attach.hs index 9861f15..298ed29 100644 --- a/src/Attach.hs +++ b/src/Attach.hs @@ -5,7 +5,6 @@ module Attach ( import Control.Monad.Except import Control.Monad.Reader -import Control.Monad.State import Crypto.Hash import Crypto.Random @@ -27,22 +26,9 @@ import State import Storage import Storage.Key -data AttachService = NoAttach - | OurRequest Bytes - | OurRequestConfirm (Maybe (UnifiedIdentity, [ScrubbedBytes])) - | OurRequestReady - | PeerRequest Bytes RefDigest - | PeerRequestConfirm - | AttachDone - | AttachFailed - -data AttachStage = AttachRequest RefDigest - | AttachResponse Bytes - | AttachRequestNonce Bytes - | AttachIdentity (Stored (Signed IdentityData)) [ScrubbedBytes] - | AttachDecline - -instance Storable AttachStage where +data AttachService + +instance Storable (ServicePacket AttachService) where store' at = storeRec $ do case at of AttachRequest x -> storeBinary "request" x @@ -72,10 +58,27 @@ instance Storable AttachStage where [] -> throwError "invalid attach stange" instance Service AttachService where - type ServicePacket AttachService = AttachStage + serviceID _ = mkServiceID "4995a5f9-2d4d-48e9-ad3b-0bf1c2a1be7f" + + data ServiceState AttachService + = NoAttach + | OurRequest Bytes + | OurRequestConfirm (Maybe (UnifiedIdentity, [ScrubbedBytes])) + | OurRequestReady + | PeerRequest Bytes RefDigest + | PeerRequestConfirm + | AttachDone + | AttachFailed emptyServiceState = NoAttach - serviceHandler spacket = gets ((,fromStored spacket) . svcValue) >>= \case + data ServicePacket AttachService + = AttachRequest RefDigest + | AttachResponse Bytes + | AttachRequestNonce Bytes + | AttachIdentity (Stored (Signed IdentityData)) [ScrubbedBytes] + | AttachDecline + + serviceHandler spacket = ((,fromStored spacket) <$> svcGet) >>= \case (NoAttach, AttachRequest confirm) -> do peer <- asks $ svcPeer svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ " initiated" @@ -86,8 +89,8 @@ instance Service AttachService where (OurRequest nonce, AttachResponse pnonce) -> do peer <- asks $ svcPeer - self <- maybe (throwError "failed to verify own identity") return =<< - gets (validateIdentity . lsIdentity . fromStored . svcLocal) + self <- maybe (throwError "failed to verify own identity") return . + validateIdentity . lsIdentity . fromStored =<< svcGetLocal svcPrint $ "Attach to " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirmationNumber (nonceDigest self peer nonce pnonce) svcSet $ OurRequestConfirm Nothing return $ Just $ AttachRequestNonce nonce @@ -113,7 +116,7 @@ instance Service AttachService where verifyAttachedIdentity sdata >>= \case Just identity -> do svcPrint $ "Accepted updated identity" - st <- gets $ storedStorage . svcLocal + st <- storedStorage <$> svcGetLocal finalizeAttach st identity keys return Nothing Nothing -> do @@ -126,8 +129,8 @@ instance Service AttachService where (PeerRequest nonce dgst, AttachRequestNonce pnonce) -> do peer <- asks $ svcPeer - self <- maybe (throwError "failed to verify own identity") return =<< - gets (validateIdentity . lsIdentity . fromStored . svcLocal) + self <- maybe (throwError "failed to verify own identity") return . + validateIdentity . lsIdentity . fromStored =<< svcGetLocal if dgst == nonceDigest peer self pnonce BA.empty then do svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirmationNumber (nonceDigest peer self pnonce nonce) svcSet PeerRequestConfirm @@ -151,14 +154,14 @@ attachToOwner _ self peer = do pid <- case peerIdentity peer of PeerIdentityFull pid -> return pid _ -> throwError "incomplete peer identity" - sendToPeerWith self peer (T.pack "attach") $ \case + sendToPeerWith self peer $ \case NoAttach -> return (Just $ AttachRequest (nonceDigest self pid nonce BA.empty), OurRequest nonce) _ -> throwError "alredy in progress" attachAccept :: (MonadIO m, MonadError String m) => (String -> IO ()) -> UnifiedIdentity -> Peer -> m () attachAccept printMsg self peer = do let st = storedStorage $ idData self - sendToPeerWith self peer (T.pack "attach") $ \case + sendToPeerWith self peer $ \case NoAttach -> throwError $ "none in progress" OurRequest {} -> throwError $ "waiting for peer" OurRequestConfirm Nothing -> do @@ -202,7 +205,7 @@ confirmationNumber dgst = let (a:b:c:d:_) = map fromIntegral $ BA.unpack dgst :: verifyAttachedIdentity :: Stored (Signed IdentityData) -> ServiceHandler s (Maybe UnifiedIdentity) verifyAttachedIdentity sdata = do - curid <- gets $ lsIdentity . fromStored . svcLocal + curid <- lsIdentity . fromStored <$> svcGetLocal secret <- maybe (throwError "failed to load own secret key") return =<< liftIO (loadKey $ iddKeyIdentity $ fromStored $ signedData $ fromStored curid) sdata' <- liftIO $ wrappedStore (storedStorage sdata) =<< signAdd secret (fromStored sdata) diff --git a/src/Main.hs b/src/Main.hs index b143253..e23e1b5 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -19,6 +19,7 @@ import Data.Maybe import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Time.LocalTime +import Data.Typeable import System.Console.Haskeline import System.Environment @@ -94,8 +95,8 @@ interactiveLoop st bhost = runInputT defaultSettings $ do chanPeer <- liftIO $ do erebosHead <- loadLocalStateHead st startServer erebosHead extPrintLn bhost - [ (T.pack "attach", SomeService (emptyServiceState :: AttachService)) - , (T.pack "dmsg", SomeService (emptyServiceState :: DirectMessageService)) + [ SomeService @AttachService Proxy + , SomeService @DirectMessageService Proxy ] peers <- liftIO $ newMVar [] @@ -224,7 +225,7 @@ cmdSend = void $ do (,smsg) <$> slistAddS thread' (lsMessages $ fromStored erb) erb' <- wrappedStore st (fromStored erb) { lsMessages = slist } return (erb', smsg) - sendToPeer self peer (T.pack "dmsg") smsg + sendToPeer self peer $ DirectMessagePacket smsg tzone <- liftIO $ getCurrentTimeZone liftIO $ putStrLn $ formatMessage tzone $ fromStored smsg diff --git a/src/Message/Service.hs b/src/Message/Service.hs index 1311e24..0a8f180 100644 --- a/src/Message/Service.hs +++ b/src/Message/Service.hs @@ -1,10 +1,10 @@ module Message.Service ( - DirectMessageService(..), + DirectMessageService, + ServicePacket(DirectMessagePacket), formatMessage, ) where import Control.Monad.Reader -import Control.Monad.State import Data.List import qualified Data.Text as T @@ -18,18 +18,24 @@ import State import Storage import Storage.List -data DirectMessageService = DirectMessageService +data DirectMessageService instance Service DirectMessageService where - type ServicePacket DirectMessageService = DirectMessage + serviceID _ = mkServiceID "c702076c-4928-4415-8b6b-3e839eafcb0d" + + data ServiceState DirectMessageService = DirectMessageService emptyServiceState = DirectMessageService - serviceHandler smsg = do - let msg = fromStored smsg + + newtype ServicePacket DirectMessageService = DirectMessagePacket (Stored DirectMessage) + + serviceHandler packet = do + let DirectMessagePacket smsg = fromStored packet + msg = fromStored smsg powner <- asks $ finalOwner . svcPeer tzone <- liftIO $ getCurrentTimeZone svcPrint $ formatMessage tzone msg if | powner `sameIdentity` msgFrom msg - -> do erb <- gets svcLocal + -> do erb <- svcGetLocal let st = storedStorage erb erb' <- liftIO $ do threads <- storedFromSList $ lsMessages $ fromStored erb @@ -38,12 +44,16 @@ instance Service DirectMessageService where slistReplaceS thread thread' $ lsMessages $ fromStored erb Nothing -> slistAdd (emptyDirectThread powner) { msgHead = [smsg] } $ lsMessages $ fromStored erb wrappedStore st (fromStored erb) { lsMessages = slist } - modify $ \s -> s { svcLocal = erb' } + svcSetLocal erb' return Nothing | otherwise -> do svcPrint "Owner mismatch" return Nothing +instance Storable (ServicePacket DirectMessageService) where + store' (DirectMessagePacket smsg) = store' smsg + load' = DirectMessagePacket <$> load' + formatMessage :: TimeZone -> DirectMessage -> String formatMessage tzone msg = concat [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ msgTime msg diff --git a/src/Network.hs b/src/Network.hs index d71e9d8..eceeaff 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -18,9 +18,10 @@ import Control.Monad.State import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL import Data.Either +import Data.List import qualified Data.Map as M import Data.Maybe -import qualified Data.Text as T +import Data.Typeable import Network.Socket import Network.Socket.ByteString (recvFrom, sendTo) @@ -48,8 +49,8 @@ data Peer = Peer , peerSocket :: Socket , peerStorage :: Storage , peerInStorage :: PartialStorage - , peerServiceState :: MVar (M.Map T.Text SomeService) - , peerServiceQueue :: [(T.Text, WaitingRef)] + , peerServiceState :: MVar (M.Map ServiceID SomeServiceState) + , peerServiceQueue :: [(ServiceID, WaitingRef)] , peerWaitingRefs :: [WaitingRef] } @@ -75,7 +76,7 @@ data TransportHeaderItem | AnnounceUpdate PartialRef | TrChannelRequest PartialRef | TrChannelAccept PartialRef - | ServiceType T.Text + | ServiceType ServiceID | ServiceRef PartialRef data TransportHeader = TransportHeader [TransportHeaderItem] @@ -90,7 +91,7 @@ transportToObject (TransportHeader items) = Rec $ map single items AnnounceUpdate ref -> (BC.pack "ANU", RecRef ref) TrChannelRequest ref -> (BC.pack "CRQ", RecRef ref) TrChannelAccept ref -> (BC.pack "CAC", RecRef ref) - ServiceType stype -> (BC.pack "STP", RecText stype) + ServiceType stype -> (BC.pack "STP", RecUUID $ toUUID stype) ServiceRef ref -> (BC.pack "SRF", RecRef ref) transportFromObject :: PartialObject -> Maybe TransportHeader @@ -105,12 +106,12 @@ transportFromObject (Rec items) = case catMaybes $ map single items of | name == BC.pack "ANU", RecRef ref <- content -> Just $ AnnounceUpdate ref | name == BC.pack "CRQ", RecRef ref <- content -> Just $ TrChannelRequest ref | name == BC.pack "CAC", RecRef ref <- content -> Just $ TrChannelAccept ref - | name == BC.pack "STP", RecText stype <- content -> Just $ ServiceType stype + | name == BC.pack "STP", RecUUID uuid <- content -> Just $ ServiceType $ fromUUID uuid | name == BC.pack "SRF", RecRef ref <- content -> Just $ ServiceRef ref | otherwise -> Nothing transportFromObject _ = Nothing -lookupServiceType :: [TransportHeaderItem] -> Maybe T.Text +lookupServiceType :: [TransportHeaderItem] -> Maybe ServiceID lookupServiceType (ServiceType stype : _) = Just stype lookupServiceType (_ : hs) = lookupServiceType hs lookupServiceType [] = Nothing @@ -152,7 +153,7 @@ receivedWaitingRef nref wr@(WaitingRef _ _ mvar) = do checkWaitingRef wr -startServer :: Head -> (String -> IO ()) -> String -> [(T.Text, SomeService)] -> IO (Chan Peer) +startServer :: Head -> (String -> IO ()) -> String -> [SomeService] -> IO (Chan Peer) startServer origHead logd bhost services = do let storage = refStorage $ headRef origHead chanPeer <- newChan @@ -242,20 +243,20 @@ startServer origHead logd bhost services = do (peer, svc, ref) | PeerIdentityFull peerId <- peerIdentity peer -> modifyMVar_ (peerServiceState peer) $ \svcs -> - case maybe (lookup svc services) Just $ M.lookup svc svcs of - Nothing -> do logd $ "unhandled service '" ++ T.unpack svc ++ "'" + case maybe (someServiceEmptyState <$> find ((svc ==) . someServiceID) services) Just $ M.lookup svc svcs of + Nothing -> do logd $ "unhandled service '" ++ show (toUUID svc) ++ "'" return svcs - Just (SomeService s) -> do + Just (SomeServiceState s) -> do let inp = ServiceInput { svcPeer = peerId , svcPrintOp = logd } (rsp, s') <- handleServicePacket storage inp s (wrappedLoad ref) identity <- readMVar midentity - runExceptT (maybe (return ()) (sendToPeer identity peer svc) rsp) >>= \case + runExceptT (maybe (return ()) (sendToPeer identity peer) rsp) >>= \case Left err -> logd $ "failed to send response to peer: " ++ show err Right () -> return () - return $ M.insert svc (SomeService s') svcs + return $ M.insert svc (SomeServiceState s') svcs | DatagramAddress paddr <- peerAddress peer -> do logd $ "service packet from peer with incomplete identity " ++ show paddr @@ -281,7 +282,7 @@ addBody :: Ref -> PacketHandler () addBody r = modify $ \ph -> ph { phBody = r : phBody ph } handlePacket :: (String -> IO ()) -> UnifiedIdentity -> Bool - -> Peer -> Chan (Peer, T.Text, Ref) + -> Peer -> Chan (Peer, ServiceID, Ref) -> TransportHeader -> IO (Maybe Peer) handlePacket logd identity secure opeer chanSvc (TransportHeader headers) = do let sidentity = idData identity @@ -513,7 +514,7 @@ handleIdentityUpdate = do _ -> return () -handleServices :: Chan (Peer, T.Text, Ref) -> PacketHandler () +handleServices :: Chan (Peer, ServiceID, Ref) -> PacketHandler () handleServices chan = gets (peerServiceQueue . phPeer) >>= \case [] -> return () queue -> do @@ -527,30 +528,31 @@ handleServices chan = gets (peerServiceQueue . phPeer) >>= \case updatePeer $ \p -> p { peerServiceQueue = queue' } -sendToPeer :: (Storable a, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> T.Text -> a -> m () -sendToPeer _ peer@Peer { peerChannel = ChannelEstablished ch } svc obj = do +sendToPeer :: (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> ServicePacket s -> m () +sendToPeer _ peer@Peer { peerChannel = ChannelEstablished ch } packet = do let st = peerInStorage peer - ref <- liftIO $ store st obj + ref <- liftIO $ store st packet bytes <- case lazyLoadBytes ref of Right bytes -> return bytes Left dgst -> throwError $ "incomplete ref " ++ show ref ++ ", missing " ++ BC.unpack (showRefDigest dgst) let plain = BL.toStrict $ BL.concat - [ serializeObject $ transportToObject $ TransportHeader [ServiceType svc, ServiceRef ref] + [ serializeObject $ transportToObject $ TransportHeader [ServiceType $ serviceID packet, ServiceRef ref] , bytes ] ctext <- channelEncrypt ch plain let DatagramAddress paddr = peerAddress peer void $ liftIO $ sendTo (peerSocket peer) ctext paddr -sendToPeer _ _ _ _ = throwError $ "no channel to peer" +sendToPeer _ _ _ = throwError $ "no channel to peer" -sendToPeerWith :: (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> T.Text -> (s -> ExceptT String IO (Maybe (ServicePacket s), s)) -> m () -sendToPeerWith identity peer svc fobj = do +sendToPeerWith :: forall s m. (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> (ServiceState s -> ExceptT String IO (Maybe (ServicePacket s), ServiceState s)) -> m () +sendToPeerWith identity peer fobj = do + let sid = serviceID @s Proxy res <- liftIO $ modifyMVar (peerServiceState peer) $ \svcs -> do - runExceptT (fobj $ fromMaybe emptyServiceState $ fromService =<< M.lookup svc svcs) >>= \case - Right (obj, s') -> return $ (M.insert svc (SomeService s') svcs, Right obj) + runExceptT (fobj $ fromMaybe emptyServiceState $ fromServiceState =<< M.lookup sid svcs) >>= \case + Right (obj, s') -> return $ (M.insert sid (SomeServiceState s') svcs, Right obj) Left err -> return $ (svcs, Left err) case res of - Right (Just obj) -> sendToPeer identity peer svc obj + Right (Just obj) -> sendToPeer identity peer obj Right Nothing -> return () Left err -> throwError err diff --git a/src/Service.hs b/src/Service.hs index 6b490ff..59b4e8e 100644 --- a/src/Service.hs +++ b/src/Service.hs @@ -1,12 +1,15 @@ module Service ( Service(..), - SomeService(..), fromService, + SomeService(..), SomeServiceState(..), + someServiceID, fromServiceState, someServiceEmptyState, + ServiceID, mkServiceID, ServiceHandler, - ServiceInput(..), ServiceState(..), + ServiceInput(..), handleServicePacket, - svcSet, + svcGet, svcSet, + svcGetLocal, svcSetLocal, svcPrint, ) where @@ -15,39 +18,59 @@ import Control.Monad.Reader import Control.Monad.State import Data.Typeable +import Data.UUID (UUID) +import qualified Data.UUID as U import Identity import State import Storage class (Typeable s, Storable (ServicePacket s)) => Service s where - type ServicePacket s :: * - emptyServiceState :: s + serviceID :: proxy s -> ServiceID + + data ServiceState s :: * + emptyServiceState :: ServiceState s + + data ServicePacket s :: * serviceHandler :: Stored (ServicePacket s) -> ServiceHandler s (Maybe (ServicePacket s)) -data SomeService = forall s. Service s => SomeService s +data SomeService = forall s. Service s => SomeService (Proxy s) + +data SomeServiceState = forall s. Service s => SomeServiceState (ServiceState s) + +someServiceID :: SomeService -> ServiceID +someServiceID (SomeService s) = serviceID s + +fromServiceState :: Service s => SomeServiceState -> Maybe (ServiceState s) +fromServiceState (SomeServiceState s) = cast s -fromService :: Service s => SomeService -> Maybe s -fromService (SomeService s) = cast s +someServiceEmptyState :: SomeService -> SomeServiceState +someServiceEmptyState (SomeService (Proxy :: Proxy s)) = SomeServiceState (emptyServiceState :: ServiceState s) + +newtype ServiceID = ServiceID UUID + deriving (Eq, Ord, StorableUUID) + +mkServiceID :: String -> ServiceID +mkServiceID = maybe (error "Invalid service ID") ServiceID . U.fromString data ServiceInput = ServiceInput { svcPeer :: UnifiedIdentity , svcPrintOp :: String -> IO () } -data ServiceState s = ServiceState - { svcValue :: s +data ServiceHandlerState s = ServiceHandlerState + { svcValue :: ServiceState s , svcLocal :: Stored LocalState } -newtype ServiceHandler s a = ServiceHandler (ReaderT ServiceInput (StateT (ServiceState s) (ExceptT String IO)) a) - deriving (Functor, Applicative, Monad, MonadReader ServiceInput, MonadState (ServiceState s), MonadError String, MonadIO) +newtype ServiceHandler s a = ServiceHandler (ReaderT ServiceInput (StateT (ServiceHandlerState s) (ExceptT String IO)) a) + deriving (Functor, Applicative, Monad, MonadReader ServiceInput, MonadState (ServiceHandlerState s), MonadError String, MonadIO) -handleServicePacket :: Service s => Storage -> ServiceInput -> s -> Stored (ServicePacket s) -> IO (Maybe (ServicePacket s), s) +handleServicePacket :: Service s => Storage -> ServiceInput -> ServiceState s -> Stored (ServicePacket s) -> IO (Maybe (ServicePacket s), ServiceState s) handleServicePacket st input svc packet = do herb <- loadLocalStateHead st let erb = wrappedLoad $ headRef herb - sstate = ServiceState { svcValue = svc, svcLocal = erb } + sstate = ServiceHandlerState { svcValue = svc, svcLocal = erb } ServiceHandler handler = serviceHandler packet (runExceptT $ flip runStateT sstate $ flip runReaderT input $ handler) >>= \case Left err -> do @@ -59,8 +82,17 @@ handleServicePacket st input svc packet = do Left _ -> handleServicePacket st input svc packet Right _ -> return (rsp, svcValue sstate') -svcSet :: s -> ServiceHandler s () +svcGet :: ServiceHandler s (ServiceState s) +svcGet = gets svcValue + +svcSet :: ServiceState s -> ServiceHandler s () svcSet x = modify $ \st -> st { svcValue = x } +svcGetLocal :: ServiceHandler s (Stored LocalState) +svcGetLocal = gets svcLocal + +svcSetLocal :: Stored LocalState -> ServiceHandler s () +svcSetLocal x = modify $ \st -> st { svcLocal = x } + svcPrint :: String -> ServiceHandler s () svcPrint str = liftIO . ($str) =<< asks svcPrintOp |