From 5572dbc8289de934e9ee5bc3f74a0f98365ce3e5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 21 Apr 2017 17:42:10 -0400 Subject: initial http server Incomplete, but the client is able to connect and send messages which get logged. Split up debug-me.hs into Role/* Switched from cereal to binary, since websockets operate on lazy ByteStrings, and using cereal would involve a copy on every receive. This commit was sponsored by Boyd Stephen Smith Jr. on Patreon. --- Role/User.hs | 252 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 252 insertions(+) create mode 100644 Role/User.hs (limited to 'Role/User.hs') diff --git a/Role/User.hs b/Role/User.hs new file mode 100644 index 0000000..9412843 --- /dev/null +++ b/Role/User.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Role.User where + +import Types +import Pty +import Memory +import Log +import Session +import Crypto +import CmdLine +import WebSockets + +import Control.Concurrent.Async +import Control.Concurrent.STM +import System.Process +import System.Exit +import qualified Data.ByteString as B +import Data.List.NonEmpty (NonEmpty(..), toList) +import Data.Monoid +import Data.Time.Clock.POSIX + +run :: UserOpts -> IO ExitCode +run os = do + (cmd, cmdparams) <- shellCommand os + exitstatus <- go cmd cmdparams startSession + sessionDone + return exitstatus + where + go cmd cmdparams startmsg = runWithPty cmd cmdparams $ \(p, ph) -> do + runClientApp $ clientApp (InitMode mempty) $ \ichan ochan -> do + uthread <- async (user startmsg p ichan ochan) + exitstatus <- waitForProcess ph + cancel uthread + return exitstatus + +shellCommand :: UserOpts -> IO (String, [String]) +shellCommand os = return ("dash", []) + +-- | Log of recent Activity, with the most recent first. +type Backlog = NonEmpty Log + +data UserState = UserState + { backLog :: Backlog + , userSessionKey :: MySessionKey + , userSigVerifier :: SigVerifier + } + +user :: B.ByteString -> Pty -> TChan (Message Seen) -> TChan (Message Entered) -> IO () +user starttxt p ochan ichan = withLogger "debug-me.log" $ \logger -> do + -- Start by establishing our session key, and displaying the starttxt. + let initialmessage msg = do + atomically $ writeTChan ochan msg + logger $ User msg + sk <- genMySessionKey + pk <- myPublicKey sk + let c = mkSigned sk $ Control (SessionKey pk) + initialmessage $ ControlMessage c + let act = mkSigned sk $ Activity (Seen (Val (starttxt <> "\r\n"))) Nothing + let startmsg = ActivityMessage act + initialmessage startmsg + l <- mkLog (User startmsg) <$> getPOSIXTime + us <- newTVarIO $ UserState + { backLog = l :| [] + , userSessionKey = sk + , userSigVerifier = mempty + } + _ <- sendPtyOutput p ochan us logger + `concurrently` sendPtyInput ichan ochan p us logger + return () + +-- | Forward things written to the Pty out the TChan. +sendPtyOutput :: Pty -> TChan (Message Seen) -> TVar UserState -> Logger -> IO () +sendPtyOutput p ochan us logger = go + where + go = do + b <- readPty p + now <- getPOSIXTime + l <- atomically $ do + let seen = Seen (Val b) + sendDeveloper ochan us seen now + logger $ User l + go + +class SendableToDeveloper t where + sendDeveloper :: TChan (Message Seen) -> TVar UserState -> t -> POSIXTime -> STM (Message Seen) + +instance SendableToDeveloper Seen where + sendDeveloper ochan us seen now = do + st <- readTVar us + let bl@(prev :| _) = backLog st + let msg = ActivityMessage $ + mkSigned (userSessionKey st) $ + Activity seen (loggedHash prev) + let l = mkLog (User msg) now + writeTChan ochan msg + writeTVar us $ st { backLog = l :| toList bl } + return msg + +instance SendableToDeveloper ControlAction where + sendDeveloper ochan us c _now = do + st <- readTVar us + let msg = ControlMessage $ + mkSigned (userSessionKey st) (Control c) + -- Control messages are not kept in the backlog. + writeTChan ochan msg + return msg + +-- | Read things to be entered from the TChan, verify if they're legal, +-- and send them to the Pty. +sendPtyInput :: TChan (Message Entered) -> TChan (Message Seen) -> Pty -> TVar UserState -> Logger -> IO () +sendPtyInput ichan ochan p us logger = go + where + go = do + now <- getPOSIXTime + v <- atomically $ getDeveloperMessage ichan ochan us now + case v of + InputMessage msg@(ActivityMessage entered) -> do + logger $ Developer msg + writePty p $ val $ enteredData $ activity entered + go + InputMessage msg@(ControlMessage (Control c _)) -> do + logger $ Developer msg + case c of + SessionKey pk -> do + checkDeveloperPublicKey ochan us logger pk + go + Rejected r -> error $ "User side received a Rejected: " ++ show r + SessionKeyAccepted _ -> error "User side received a SessionKeyAccepted" + SessionKeyRejected _ -> error "User side received a SessionKeyRejected" + RejectedMessage rej -> do + logger $ User rej + go + BadlySignedMessage _ -> go + +data Input + = InputMessage (Message Entered) + | RejectedMessage (Message Seen) + | BadlySignedMessage (Message Entered) + +-- Get message from developer, verify its signature is from a developer we +-- have allowed (unless it's a SessionKey control message, then the +-- signature of the message is only verified against the key in it), and +-- make sure it's legal before returning it. If it's not legal, sends a +-- Reject message. +getDeveloperMessage :: TChan (Message Entered) -> TChan (Message Seen) -> TVar UserState -> POSIXTime -> STM Input +getDeveloperMessage ichan ochan us now = do + msg <- readTChan ichan + st <- readTVar us + case msg of + ControlMessage (Control (SessionKey pk) _) -> do + let sigverifier = mkSigVerifier pk + if verifySigned sigverifier msg + then return (InputMessage msg) + else return (BadlySignedMessage msg) + _ -> if verifySigned (userSigVerifier st) msg + then case msg of + ActivityMessage entered -> do + -- Don't need to retain backlog + -- before the Activity that entered + -- references. + let bl' = reduceBacklog $ + truncateBacklog (backLog st) entered + if isLegalEntered entered (st { backLog = bl' }) + then do + let l = mkLog (Developer msg) now + writeTVar us (st { backLog = l :| toList bl' }) + return (InputMessage msg) + else do + let reject = Rejected entered + RejectedMessage <$> sendDeveloper ochan us reject now + ControlMessage (Control _ _) -> + return (InputMessage msg) + else return (BadlySignedMessage msg) + +-- | Check if the public key a developer presented is one we want to use, +-- and if so, add it to the userSigVerifier. +checkDeveloperPublicKey :: TChan (Message Seen) -> TVar UserState -> Logger -> PublicKey -> IO () +checkDeveloperPublicKey ochan us logger pk = do + now <- getPOSIXTime + -- TODO check gpg sig.. + msg <- atomically $ do + st <- readTVar us + let sv = userSigVerifier st + let sv' = sv `mappend` mkSigVerifier pk + let st' = st { userSigVerifier = sv' } + writeTVar us st' + sendDeveloper ochan us (SessionKeyAccepted pk) now + logger $ User msg + +-- | Truncate the Backlog to remove entries older than the one +-- that the Activity Entered refers to, but only if the referred +-- to Activity is an Activity Seen. +-- +-- Once the developer has referred to a given Activity Seen in +-- their Activity Entered, they cannot refer backwards to anything +-- that came before it. +-- +-- If the Activity refers to an item not in the backlog, no truncation is +-- done. +truncateBacklog :: Backlog -> Activity Entered -> Backlog +truncateBacklog (b :| l) (Activity _ (Just hp) _) + | truncationpoint b = b :| [] + | otherwise = b :| go [] l + where + go c [] = reverse c + go c (x:xs) + | truncationpoint x = reverse (x:c) + | otherwise = go (x:c) xs + truncationpoint x@(Log { loggedMessage = User {}}) = loggedHash x == Just hp + truncationpoint _ = False +truncateBacklog bl (Activity _ Nothing _) = bl + +-- | To avoid DOS attacks that try to fill up the backlog and so use all +-- memory, don't let the backlog contain more than 1000 items, or +-- more than 16 megabytes of total data. (Excluding the most recent +-- item). +reduceBacklog :: Backlog -> Backlog +reduceBacklog (b :| l) = b :| go 0 (take 1000 l) + where + go _ [] = [] + go n (x:xs) + | n > 16777216 = [] + | otherwise = x : go (n + dataSize x) xs + +-- | Entered activity is legal when it points to the last logged activity, +-- because this guarantees that the person who entered it saw +-- the current state of the system before manipulating it. +-- +-- To support typeahead on slow links, some echoData may be provided +-- in the Entered activity. If the Entered activity points +-- to an older activity, then the echoData must match the +-- concatenation of all Seen activities after that one, up to the +-- last logged activity. +-- +-- Activities that do not enter data point to the first message +-- sent in the debug-me session. +-- +-- Does not check the signature. +isLegalEntered :: Activity Entered -> UserState -> Bool +isLegalEntered (Activity _ Nothing _) _ = False +isLegalEntered (Activity a (Just hp) _) us + | loggedHash lastact == Just hp = True + | B.null (val (echoData a)) = False -- optimisation + | any (== Just hp) (map loggedHash bl) = + let sincehp = reverse (lastact : takeWhile (\l -> loggedHash l /= Just hp) bl) + in echoData a == mconcat (map (getseen . loggedMessage) sincehp) + | otherwise = False + where + (lastact :| bl) = backLog us + getseen (User (ActivityMessage as)) = seenData $ activity as + getseen _ = mempty -- cgit v1.2.3