Skip to content

Commit 8727be8

Browse files
dmjiodmjio
authored
Merge pull request #10 from mpickering/wip/romes/logger
Refactoring to use logging framework
2 parents 243e585 + 967b526 commit 8727be8

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)