Logger implementation code. Fixes #6. Logging to file remaining

diff --git a/src/Logger.hs b/src/Logger.hs
new file mode 100644 (file)
index 0000000..5863cce
--- /dev/null
+++ b/src/Logger.hs
@@ -0,0 +1,55 @@
+module Logger (
+      Logger
+    , initLogger
+    , logMessage
+    , logStop
+    ) where
+
+import Control.Concurrent
+
+-- The below logger implementation has been taken from
+-- Parallel and Concurrent Programming in Haskell, Chapter 7
+-- The logger is implemented in a concurrent thread.
+
+-- Here the (MVar LogCommand) is used for actual thread communication
+-- So if multiple threads try to log, then the logger will be thread-safe
+-- Also the 'loop' in logger will wait for the message to come.
+-- 
+-- The MVar in stop is just to ensure the logger thread executes completely
+-- Before exiting the main application.
+--
+data Logger = Logger (MVar LogCommand)
+data LogCommand = Message String | Stop (MVar ())
+
+initLogger :: IO Logger
+initLogger = do
+    m <- newEmptyMVar
+    let l = Logger m
+    _ <- forkIO (logger l)
+    return l
+
+logger :: Logger -> IO ()
+logger (Logger m) = loop
+    where
+        loop = do
+            cmd <- takeMVar m
+            case cmd of
+                 Message msg -> do
+                     -- We can alternatively put the message to a file
+                     putStrLn msg
+                     -- Recursive
+                     loop
+                 Stop s -> do
+                     putStrLn "FuncTorrent: Exit succesfully"
+                     putMVar s ()
+
+-- Send log message to logger
+logMessage :: Logger -> String -> IO ()
+logMessage (Logger m) s = putMVar m (Message s)
+
+logStop :: Logger -> IO ()
+logStop (Logger m) = do
+    s <- newEmptyMVar
+    putMVar m (Stop s)
+    -- Wait for logger to complete the logging
+    takeMVar s

diff --git a/src/Main.hs b/src/Main.hs
index 50eb5d1e650da9d48e990db5e487f6e6cb9b7a0a..2213ac97a5244f3f9b457b77031dc904c1274a99 100644 (file)
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -11,9 +11,10 @@ import System.Environment (getArgs)
 import System.Exit (exitSuccess)
 import Tracker (connect, prepareRequest)
 import Text.ParserCombinators.Parsec (ParseError)
+import Logger
 
-printError :: ParseError -> IO ()
-printError e = putStrLn $ "parse error: " ++ show e
+printError :: ParseError -> Logger -> IO ()
+printError e l = logMessage l $ "parse error: \n" ++ show e
 
 peerId :: String
 peerId = "-HS0001-*-*-20150215"
@@ -32,16 +33,23 @@ parse _ = exit
 main :: IO ()
 main = do
     args <- getArgs
+    logR <- initLogger
+    logMessage logR $ "Starting parsing input file: " ++ (concat args)
     torrentStr <- parse args
     case decode torrentStr of
       Right d ->
           case mkMetaInfo d of
-            Nothing -> putStrLn "parse error"
+            Nothing -> logMessage logR "parse error"
             Just m -> do
               let len = lengthInBytes $ info m
                   (Bdict d') = d
               body <- pack <$> connect (announce m) (prepareRequest d' peerId len)
-              print $ getPeers $ getPeerResponse body
-              print $ length $ handShakeMsg d' peerId
-      Left e -> printError e
-    putStrLn "done"
+              
+              let peerResponse = show $ getPeers $ getPeerResponse body
+              logMessage logR $ "Peers List : " ++ peerResponse
+              
+              let hsMsgLen = show $ length $ handShakeMsg d' peerId
+              logMessage logR $ "Hand-shake message length : " ++ hsMsgLen
+
+      Left e -> printError e logR
+    logStop logR