Skip to content

Commit 967b526

Browse files
mpickeringalt-romes
mpickering
authored and
alt-romes
committed
Refactoring to use logging framework
To implement OutputEvents we may need to capture the stdout and stderr of the debuggee. However, if the DAP server is also outputting to stdout and stderr its messages will be mixed up with the debuggee's. This commit introduces a logging action to ensure it is possible to redirect all of the DAP server's output to a particular handle, thereby separating it from the debuggee. Fixes #9
1 parent 243e585 commit 967b526

File tree

7 files changed

+191
-128
lines changed

7 files changed

+191
-128
lines changed

‎dap.cabal‎

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,7 @@ library
2626
DAP.Server
2727
DAP.Types
2828
DAP.Utils
29+
DAP.Log
2930
build-depends:
3031
aeson >= 2.0.3 && < 2.3,
3132
aeson-pretty >= 0.8.9 && < 0.9,
@@ -41,7 +42,8 @@ library
4142
time >= 1.11.1 && < 1.12,
4243
unordered-containers >= 0.2.19 && < 0.3,
4344
stm >= 2.5.0 && < 2.6,
44-
transformers-base >= 0.4.6 && < 0.5
45+
transformers-base >= 0.4.6 && < 0.5,
46+
co-log-core >= 0.3 && < 0.4
4547
ghc-options:
4648
-Wall
4749
hs-source-dirs:
@@ -66,6 +68,7 @@ test-suite tests
6668
DAP.Types
6769
DAP.Event
6870
DAP.Utils
71+
DAP.Log
6972
build-depends:
7073
aeson
7174
, aeson-pretty
@@ -85,6 +88,7 @@ test-suite tests
8588
, time
8689
, transformers-base
8790
, unordered-containers
91+
, co-log-core
8892
default-language:
8993
Haskell2010
9094

‎src/DAP/Adaptor.hs‎

Lines changed: 52 additions & 48 deletions
Original file line numberDiff line numberDiff line change
@@ -6,13 +6,15 @@
66
-- Stability : experimental
77
-- Portability : non-portable
88
----------------------------------------------------------------------------
9+
{-# LANGUAGE CPP #-}
910
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1011
{-# LANGUAGE DerivingStrategies #-}
1112
{-# LANGUAGE OverloadedStrings #-}
1213
{-# LANGUAGE RecordWildCards #-}
1314
{-# LANGUAGE DeriveAnyClass #-}
1415
{-# LANGUAGE DeriveGeneric #-}
1516
{-# LANGUAGE LambdaCase #-}
17+
{-# LANGUAGE OverloadedStrings #-}
1618
----------------------------------------------------------------------------
1719
module DAP.Adaptor
1820
( -- * Message Construction
@@ -51,16 +53,18 @@ module DAP.Adaptor
5153
-- from child threads (useful for handling asynchronous debugger events).
5254
, runAdaptorWith
5355
, runAdaptor
56+
, withRequest
57+
, getHandle
5458
) where
5559
----------------------------------------------------------------------------
5660
import Control.Concurrent.Lifted ( fork, killThread )
5761
import Control.Exception ( throwIO )
5862
import Control.Concurrent.STM ( atomically, readTVarIO, modifyTVar' )
59-
import Control.Monad ( when, unless, void )
60-
import Control.Monad.Except ( runExceptT, throwError )
63+
import Control.Monad ( when, unless )
64+
import Control.Monad.Except ( runExceptT, throwError, mapExceptT )
6165
import Control.Monad.State ( runStateT, gets, gets, modify' )
6266
import Control.Monad.IO.Class ( liftIO )
63-
import Control.Monad.Reader ( asks, ask, runReaderT )
67+
import Control.Monad.Reader ( asks, ask, runReaderT, withReaderT )
6468
import Data.Aeson ( FromJSON, Result (..), fromJSON )
6569
import Data.Aeson.Encode.Pretty ( encodePretty )
6670
import Data.Aeson.Types ( object, Key, KeyValue((.=)), ToJSON )
@@ -71,61 +75,55 @@ import System.IO ( Handle )
7175
import qualified Data.ByteString.Lazy.Char8 as BL8
7276
import qualified Data.ByteString.Char8 as BS
7377
import qualified Data.HashMap.Strict as H
78+
import qualified Data.Text as T
79+
import qualified Data.Text.Encoding as TE
7480
----------------------------------------------------------------------------
7581
import DAP.Types
7682
import DAP.Utils
83+
import DAP.Log
7784
import DAP.Internal
7885
----------------------------------------------------------------------------
79-
logWarn :: BL8.ByteString -> Adaptor app request ()
86+
logWarn :: T.Text -> Adaptor app request ()
8087
logWarn msg = logWithAddr WARN Nothing (withBraces msg)
8188
----------------------------------------------------------------------------
82-
logError :: BL8.ByteString -> Adaptor app request ()
89+
logError :: T.Text -> Adaptor app request ()
8390
logError msg = logWithAddr ERROR Nothing (withBraces msg)
8491
----------------------------------------------------------------------------
85-
logInfo :: BL8.ByteString -> Adaptor app request ()
92+
logInfo :: T.Text -> Adaptor app request ()
8693
logInfo msg = logWithAddr INFO Nothing (withBraces msg)
8794
----------------------------------------------------------------------------
8895
-- | Meant for internal consumption, used to signify a message has been
8996
-- SENT from the server
90-
debugMessage :: BL8.ByteString -> Adaptor app request ()
91-
debugMessage msg = do
92-
shouldLog <- getDebugLogging
93-
addr <- getAddress
94-
liftIO
95-
$ when shouldLog
96-
$ logger DEBUG addr (Just SENT) msg
97+
debugMessage :: DebugStatus -> BL8.ByteString -> Adaptor app request ()
98+
debugMessage dir msg = do
99+
#if MIN_VERSION_text(2,0,0)
100+
logWithAddr DEBUG (Just dir) (TE.decodeUtf8Lenient (BL8.toStrict msg))
101+
#else
102+
logWithAddr DEBUG (Just dir) (TE.decodeUtf8 (BL8.toStrict msg))
103+
#endif
97104
----------------------------------------------------------------------------
98105
-- | Meant for external consumption
99-
logWithAddr :: Level -> Maybe DebugStatus -> BL8.ByteString -> Adaptor app request ()
106+
logWithAddr :: Level -> Maybe DebugStatus -> T.Text -> Adaptor app request ()
100107
logWithAddr level status msg = do
101108
addr <- getAddress
102-
liftIO (logger level addr status msg)
109+
logAction <- getLogAction
110+
liftIO (logger logAction level addr status msg)
103111
----------------------------------------------------------------------------
104112
-- | Meant for external consumption
105-
logger :: Level -> SockAddr -> Maybe DebugStatus -> BL8.ByteString -> IO ()
106-
logger level addr maybeDebug msg = do
107-
liftIO
108-
$ withGlobalLock
109-
$ BL8.putStrLn formatted
110-
where
111-
formatted
112-
= BL8.concat
113-
[ withBraces $ BL8.pack (show addr)
114-
, withBraces $ BL8.pack (show level)
115-
, maybe mempty (withBraces . BL8.pack . show) maybeDebug
116-
, msg
117-
]
118-
----------------------------------------------------------------------------
119-
getDebugLogging :: Adaptor app request Bool
120-
getDebugLogging = asks (debugLogging . serverConfig)
113+
logger :: LogAction IO DAPLog -> Level -> SockAddr -> Maybe DebugStatus -> T.Text -> IO ()
114+
logger logAction level addr maybeDebug msg =
115+
logAction <& DAPLog level maybeDebug addr msg
121116
----------------------------------------------------------------------------
122117
getServerCapabilities :: Adaptor app request Capabilities
123118
getServerCapabilities = asks (serverCapabilities . serverConfig)
124119
----------------------------------------------------------------------------
125120
getAddress :: Adaptor app request SockAddr
126121
getAddress = asks address
127122
----------------------------------------------------------------------------
128-
getHandle :: Adaptor app request Handle
123+
getLogAction :: Adaptor app request (LogAction IO DAPLog)
124+
getLogAction = asks logAction
125+
----------------------------------------------------------------------------
126+
getHandle :: Adaptor app r Handle
129127
getHandle = asks handle
130128
----------------------------------------------------------------------------
131129
getRequestSeqNum :: Adaptor app Request Seq
@@ -178,7 +176,7 @@ registerNewDebugSession k v debuggerConcurrentActions = do
178176
DebuggerThreadState
179177
<$> sequence [fork $ action (runAdaptorWith lcl' emptyState) | action <- debuggerConcurrentActions]
180178
liftIO . atomically $ modifyTVar' store (H.insert k (debuggerThreadState, v))
181-
logInfo $ BL8.pack $ "Registered new debug session: " <> unpack k
179+
logInfo $ T.pack $ "Registered new debug session: " <> unpack k
182180
setDebugSessionId k
183181

184182
----------------------------------------------------------------------------
@@ -220,7 +218,7 @@ destroyDebugSession = do
220218
liftIO $ do
221219
mapM_ killThread debuggerThreads
222220
atomically $ modifyTVar' store (H.delete sessionId)
223-
logInfo $ BL8.pack $ "SessionId " <> unpack sessionId <> " ended"
221+
logInfo $ T.pack $ "SessionId " <> unpack sessionId <> " ended"
224222
----------------------------------------------------------------------------
225223
getAppStore :: Adaptor app request (AppStore app)
226224
getAppStore = asks appStore
@@ -279,8 +277,8 @@ sendEvent action = do
279277
messageType <- gets messageType
280278
address <- getAddress
281279
let errorMsg =
282-
"Use 'send' function when responding to a DAP request, 'sendEvent'\
283-
\ is for responding to events"
280+
"Use 'send' function when responding to a DAP request, "
281+
<> "'sendEvent' is for responding to events"
284282
case messageType of
285283
MessageTypeResponse ->
286284
sendError (ErrorMessage errorMsg) Nothing
@@ -305,7 +303,7 @@ writeToHandle
305303
-> Adaptor app request ()
306304
writeToHandle _ handle evt = do
307305
let msg = encodeBaseProtocolMessage evt
308-
debugMessage ("\n" <> encodePretty evt)
306+
debugMessage SENT ("\n" <> encodePretty evt)
309307
withConnectionLock (BS.hPutStr handle msg)
310308
----------------------------------------------------------------------------
311309
-- | Resets Adaptor's payload
@@ -418,23 +416,26 @@ getArguments = do
418416
let msg = "No args found for this message"
419417
case maybeArgs of
420418
Nothing -> do
421-
logError (BL8.pack msg)
419+
logError msg
422420
liftIO $ throwIO (ExpectedArguments msg)
423421
Just val ->
424422
case fromJSON val of
425423
Success r -> pure r
426-
x -> do
427-
logError (BL8.pack (show x))
428-
liftIO $ throwIO (ParseException (show x))
424+
Error reason -> do
425+
logError (T.pack reason)
426+
liftIO $ throwIO (ParseException reason)
429427
----------------------------------------------------------------------------
430428
-- | Evaluates Adaptor action by using and updating the state in the MVar
431-
runAdaptorWith
432-
:: AdaptorLocal app request
433-
-> AdaptorState
434-
-> Adaptor app request ()
435-
-> IO ()
436-
runAdaptorWith lcl st (Adaptor action) =
437-
void (runStateT (runReaderT (runExceptT action) lcl) st)
429+
runAdaptorWith :: AdaptorLocal app request -> AdaptorState -> Adaptor app request () -> IO ()
430+
runAdaptorWith lcl st (Adaptor action) = do
431+
(es,final_st) <- runStateT (runReaderT (runExceptT action) lcl) st
432+
case es of
433+
Left err -> error ("runAdaptorWith, unhandled exception:" <> show err)
434+
Right () -> case final_st of
435+
AdaptorState _ p ->
436+
if null p
437+
then return ()
438+
else error $ "runAdaptorWith, unexpected payload:" <> show p
438439
----------------------------------------------------------------------------
439440
-- | Utility for evaluating a monad transformer stack
440441
runAdaptor :: AdaptorLocal app Request -> AdaptorState -> Adaptor app Request () -> IO ()
@@ -444,3 +445,6 @@ runAdaptor lcl s (Adaptor client) =
444445
runAdaptor lcl s' (sendErrorResponse errorMessage maybeMessage)
445446
(Right (), _) -> pure ()
446447
----------------------------------------------------------------------------
448+
449+
withRequest :: Request -> Adaptor app Request a -> Adaptor app r a
450+
withRequest r (Adaptor client) = Adaptor (mapExceptT (withReaderT (\lcl -> lcl { request = r })) client)

‎src/DAP/Internal.hs‎

Lines changed: 1 addition & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -9,16 +9,9 @@
99
----------------------------------------------------------------------------
1010
module DAP.Internal
1111
( withLock
12-
, withGlobalLock
1312
) where
1413
----------------------------------------------------------------------------
15-
import Control.Concurrent ( modifyMVar_, newMVar, MVar )
16-
import System.IO.Unsafe ( unsafePerformIO )
17-
----------------------------------------------------------------------------
18-
-- | Used for logging in the presence of multiple threads.
19-
lock :: MVar ()
20-
{-# NOINLINE lock #-}
21-
lock = unsafePerformIO $ newMVar ()
14+
import Control.Concurrent
2215
----------------------------------------------------------------------------
2316
-- | Used for performing actions (e.g. printing debug logs to stdout)
2417
-- Also used for writing to each connections Handle.
@@ -29,11 +22,3 @@ lock = unsafePerformIO $ newMVar ()
2922
withLock :: MVar () -> IO () -> IO ()
3023
withLock mvar action = modifyMVar_ mvar $ \x -> x <$ action
3124
----------------------------------------------------------------------------
32-
-- | Used for performing actions (e.g. printing debug logs to stdout)
33-
-- Ensures operations occur one thread at a time.
34-
--
35-
-- Used internally only
36-
--
37-
withGlobalLock :: IO () -> IO ()
38-
withGlobalLock = withLock lock
39-
----------------------------------------------------------------------------

‎src/DAP/Log.hs‎

Lines changed: 46 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,46 @@
1+
module DAP.Log (
2+
DebugStatus (..)
3+
, DAPLog(..)
4+
, LogAction(..)
5+
, Level(..)
6+
, (<&)
7+
, cmap
8+
, cfilter
9+
, mkDebugMessage
10+
, renderDAPLog
11+
) where
12+
13+
import Data.Text (Text)
14+
import Network.Socket ( SockAddr )
15+
import Colog.Core
16+
import qualified Data.Text as T
17+
import DAP.Utils
18+
19+
----------------------------------------------------------------------------
20+
data Level = DEBUG | INFO | WARN | ERROR
21+
deriving (Show, Eq)
22+
----------------------------------------------------------------------------
23+
data DebugStatus = SENT | RECEIVED
24+
deriving (Show, Eq)
25+
26+
data DAPLog =
27+
DAPLog {
28+
severity :: Level
29+
, mDebugStatus :: Maybe DebugStatus
30+
, addr :: SockAddr
31+
, message :: Text
32+
}
33+
| GenericMessage { severity :: Level, message :: Text }
34+
35+
mkDebugMessage :: Text -> DAPLog
36+
mkDebugMessage = GenericMessage DEBUG
37+
38+
renderDAPLog :: DAPLog -> Text
39+
renderDAPLog (GenericMessage _ t) = t
40+
renderDAPLog (DAPLog level maybeDebug log_addr msg) = T.concat
41+
[ withBraces $ T.pack (show log_addr)
42+
, withBraces $ T.pack (show level)
43+
, maybe mempty (withBraces . T.pack . show) maybeDebug
44+
, msg
45+
]
46+

0 commit comments

Comments
 (0)