summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Attach.hs57
-rw-r--r--src/Main.hs7
-rw-r--r--src/Message/Service.hs26
-rw-r--r--src/Network.hs52
-rw-r--r--src/Service.hs62
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