content: -- Copyright 2013 Evan Laforge
  -- This program is distributed under the terms of the GNU General Public
  -- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt
  
  {- | This is a standalone program to monitor the log file.
  
      It reads lines and streams them to the GUI, which displays them in
      a scrolling box.  Clickable text is surrounded by @{}@s and will be
      highlighted blue in the GUI.  When it's clicked, the GUI sends the tag
      back, much like an HTML href.  For example, stack traces are formatted as
      a REPL cmd that will highlight that location on the score.
  
      The top line is the status bar, which extracts and remembers bits of
      specially formatted log msgs.  This effectively functions as the app's
      global status bar, since otherwise it has no place for this kind of
      information.  The configuration is 'default_catch_patterns'.
  
      This also maintains a filter.  The filter is a little language that will
      filter out messages that don't match, documented by
      'Process.compile_filter'.
  
      In addition, there is a concept of 'Process.CatchPattern's.  These are
      regexes which are matched against msg text.  When one matches, the matched
      groups are kept in a status line.  That way, events reported in the log can
      be collected together.
  -}
  module LogView.LogView where
  import qualified Control.Concurrent as Concurrent
  import qualified Control.Concurrent.STM as STM
  import qualified Control.Concurrent.STM.TChan as TChan
  import qualified Control.Exception as Exception
  import qualified Control.Monad.State as State
  
  import qualified Data.ByteString.Char8 as ByteString
  import qualified Data.List as List
  import qualified Data.Text as Text
  import qualified Data.Text.IO as Text.IO
  
  import qualified GHC.IO.Encoding as Encoding
  import qualified System.Console.GetOpt as GetOpt
  import qualified System.Directory as Directory
  import qualified System.Environment
  import qualified System.Exit
  import qualified System.Posix as Posix
  
  import qualified Util.Exceptions as Exceptions
  import qualified Util.Fltk as Fltk
  import qualified Util.FltkUtil as FltkUtil
  import qualified Util.Lists as Lists
  import qualified Util.Log as Log
  import qualified Util.Processes as Processes
  
  import qualified App.Path as Path
  import qualified App.ReplProtocol as ReplProtocol
  import qualified LogView.LogViewC as LogViewC
  import qualified LogView.Process as Process
  import qualified LogView.Tail as Tail
  
  import           Global
  
  
  -- | I use this file to only start one logview at a time.
  pid_file :: FilePath
  pid_file = "log/logview.pid"
  
  -- | Initial contents of the filter field.
  initial_filter :: Text
  initial_filter = "**"
  
  initial_size :: (Int, Int)
  initial_size = (900, 300)
  
  -- | Built-in list of catch patterns.
  --
  -- I wound up having the app emit catch patterns explicitly instead of putting
  -- the smarts in logview, so now the only CatchPattern is
  -- 'Process.global_status_pattern'.  But it still seems conceivable that
  -- someday I may want logview to catch things the app didn't explicitly mean to
  -- be caught, so I'll leave this functionality in for now.
  default_catch_patterns :: [Process.CatchPattern]
  default_catch_patterns = [Process.global_status_pattern]
  
  -- | Remember this many log msgs.
  default_history :: Int
  default_history = 1000
  
  -- | UI will remember this many bytes.  This is not the same as
  -- 'default_history' because the history will remember filtered out msgs, and
  -- the UI doesn't bother to preserve msg boundaries so it uses bytes.
  default_max_bytes :: Int
  default_max_bytes = default_history * 100
  
  data Flag = Help | Seek (Maybe Integer) | Print | History Int | File FilePath
      | Geometry FltkUtil.Geometry
      deriving (Eq, Show)
  
  options :: [GetOpt.OptDescr Flag]
  options =
      [ GetOpt.Option [] ["help"] (GetOpt.NoArg Help) "display usage"
      , GetOpt.Option [] ["seek"] (GetOpt.OptArg (Seek . fmap read) "lines") $
          "if given no arg, scan the log file from the beginning, if given an"
          ++ " arg, scan approximately that many lines from the end (assuming"
          ++ " the average line is 200 bytes)"
      , GetOpt.Option [] ["print"] (GetOpt.NoArg Print)
          "print formatted logs to stdout instead of bringing up the GUI"
      , GetOpt.Option [] ["history"]
          (GetOpt.ReqArg (History . read) (show default_history))
          "remember this many lines"
      , GetOpt.Option [] ["file"] (GetOpt.ReqArg File "seq.log")
          "read from this file"
      , FltkUtil.option Geometry
      ]
  
  type LogChan = TChan.TChan Log.Msg
  
  main :: IO ()
  main = do
      Encoding.setLocaleEncoding Encoding.utf8
      args <- System.Environment.getArgs
      (flags, args) <- case GetOpt.getOpt GetOpt.Permute options args of
          (flags, args, []) -> return (flags, args)
          (_, _, errs) -> usage $ "flag errors:\n" ++ Lists.join ", " errs
      unless (null args) $
          usage ("unparsed args: " ++ show args)
      when (Help `elem` flags) (usage "usage:")
      whenJustM write_pid $ \pid -> do
          putStrLn $ "logview already running with pid " ++ show pid
          System.Exit.exitSuccess
      logview flags `Exception.finally` Directory.removeFile pid_file
      where
      usage msg = do
          putStrLn $ "ERROR: " ++ msg
          putStrLn "usage: logview [ flags ]"
          putStr (GetOpt.usageInfo "" options)
          System.Exit.exitFailure
  
  logview :: [Flag] -> IO ()
  logview flags = do
      let seek = fromMaybe (Just 0) $ Lists.last [s | Seek s <- flags]
          history = fromMaybe default_history $
              Lists.last [n | History n <- flags]
      filename <- maybe Tail.log_filename return $
          Lists.last [n | File n <- flags]
      hdl <- Tail.open filename seek
      log_chan <- STM.newTChanIO
      gui_chan <- if Print `elem` flags then return Nothing
          else Just <$> Fltk.new_channel
      main_thread <- Concurrent.myThreadId
      Concurrent.forkFinally (tail_loop log_chan hdl) $ \result -> do
          putStrLn $ "tail loop died: " ++ either show (const "no exception")
              (result :: Either Exception.SomeException ())
          maybe (Concurrent.killThread main_thread) Fltk.quit gui_chan
      case gui_chan of
          Nothing -> print_logs log_chan
          Just chan -> gui geometry chan log_chan filename history
              where geometry = Lists.head [g | Geometry g <- flags]
      where
      tail_loop log_chan hdl = do
          (msg, hdl) <- Tail.tail hdl
          STM.atomically $ TChan.writeTChan log_chan msg
          tail_loop log_chan hdl
  
  -- | If a logview is already running, return its pid, otherwise write the
  -- current pid.
  write_pid :: IO (Maybe Posix.ProcessID)
  write_pid = do
      -- I have to use ByteString.readFile and writeFile to avoid GHC's obnoxious
      -- file locking.
      pid_str <- Exceptions.ignoreEnoent $ ByteString.readFile pid_file
      existing <- case ByteString.readInt =<< pid_str of
          Just (pid_, _) -> do
              maybe_cmd <- Processes.commandName pid
              return $ if maybe False ("logview" `List.isSuffixOf`) maybe_cmd
                  then Just pid else Nothing
              where pid = fromIntegral pid_
          _ -> return Nothing
      when (existing == Nothing) $ do
          pid <- Posix.getProcessID
          ByteString.writeFile pid_file (ByteString.pack (show pid) <> "\n")
      return existing
  
  gui :: Maybe FltkUtil.Geometry -> Fltk.Channel -> LogChan -> FilePath -> Int
      -> IO ()
  gui geometry chan log_chan filename history = do
      filename <- Directory.canonicalizePath filename
      let (x, y, w, h) =
              FltkUtil.xywh 20 20 (fst initial_size) (snd initial_size) geometry
      win <- Fltk.run_action $
          LogViewC.create x y w h filename default_max_bytes
      Fltk.run_action $ LogViewC.set_filter win initial_filter
      let state = (Process.initial_state initial_filter)
              { Process.state_catch_patterns = default_catch_patterns }
      Concurrent.forkIO $ handle_msgs chan state history log_chan win
      Fltk.event_loop chan
  
  print_logs :: LogChan -> IO ()
  print_logs log_chan = forever $
      Text.IO.putStrLn . Log.format_msg
          =<< STM.atomically (TChan.readTChan log_chan)
  
  data Msg = NewLog Log.Msg | ClickedWord Text | FilterChanged Text
      deriving (Show)
  
  handle_msgs :: Fltk.Channel -> Process.State -> Int -> LogChan
      -> LogViewC.Window -> IO ()
  handle_msgs chan st history log_chan win = do
      Path.AppDir app_dir_ <- Path.get_app_dir
      let app_dir = txt app_dir_ <> "/"
      flip State.evalStateT st $ forever $ do
          ui_msg <- liftIO $ get_msg log_chan win
          case ui_msg of
              NewLog msg_ -> do
                  let msg = strip_paths app_dir msg_
                  State.modify (Process.add_msg history msg)
                  handle_new_msg chan win msg
              ClickedWord word -> liftIO $ handle_clicked_word word
              FilterChanged expr -> do
                  -- clear and redisplay msgs with new filter
                  send_action chan $ LogViewC.clear_logs win
                  State.modify $ \st ->
                      st { Process.state_filter = Process.compile_filter expr }
                  all_msgs <- State.gets (reverse . Process.state_msgs)
                  mapM_ (handle_new_msg chan win) all_msgs
  
  -- | Internally I use absolute paths, but they're pretty verbose.  So turn
  -- them back into relative paths.
  strip_paths :: Text -> Log.Msg -> Log.Msg
  strip_paths dir msg =
      msg { Log.msg_text = Text.replace dir "" $ Log.msg_text msg }
  
  handle_new_msg :: Fltk.Channel -> LogViewC.Window -> Log.Msg
      -> State.StateT Process.State IO ()
  handle_new_msg chan win msg = do
      state <- State.get
      let (styled, new_state) = Process.process_msg state msg
      State.put new_state
      case styled of
          Just (Process.StyledText txt style) -> send_action chan $ do
              LogViewC.append_log win txt style
              -- This is an experimental feature to draw more attention when
              -- there's an interesting log msg.
              when (Log.msg_priority msg >= Log.Warn) $
                  LogViewC.bring_to_front win
          Nothing -> return ()
      let new_status = Process.state_status new_state
      when (Process.state_status state /= new_status) $ do
          let (Process.StyledText status style) = Process.render_status new_status
          send_action chan $ LogViewC.set_status win status style
          State.modify $ \st -> st { Process.state_status = new_status }
  
  handle_clicked_word :: Text -> IO ()
  handle_clicked_word word
      | "{" `Text.isPrefixOf` word && "}" `Text.isSuffixOf` word =
          send_to_seq (Text.drop 1 (Text.dropEnd 1 word))
      | otherwise = putStrLn $ "logview: unknown clicked word: " ++ show word
  
  send_action :: State.MonadIO m => Fltk.Channel -> Fltk.Fltk () -> m ()
  send_action chan = liftIO . Fltk.action chan
  
  send_to_seq :: Text -> IO ()
  send_to_seq cmd = do
      response <- ReplProtocol.query_cmd_simple cmd
      unless (Text.null response) $
          Text.IO.putStrLn $ "response: " <> response
  
  get_msg :: LogChan -> LogViewC.Window -> IO Msg
  get_msg log_chan win = STM.atomically $
      fmap NewLog (STM.readTChan log_chan)
      `STM.orElse` fmap parse_ui_msg (Fltk.read_msg win)
  
  parse_ui_msg :: Fltk.Msg LogViewC.MsgType -> Msg
  parse_ui_msg (Fltk.Msg typ s) = case typ of
      LogViewC.Click -> ClickedWord s
      LogViewC.Command -> FilterChanged s
      LogViewC.Unknown n -> error $ "unknown msg type: " ++ show n
  