{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Main (main) where

import Blessings.Text
import Control.Concurrent.Extended
import Control.Exception
import Control.Monad
import qualified Data.Text.Extended as T
import qualified Data.Text.IO as T
import DBus
import DBus.Client
import DBus.Socket
import DBus.Internal.Message
import DBus.Internal.Types
import Flameshot.Internal
import qualified Flameshot.Internal.Process as P
--import System.Exit
import System.Environment
import System.IO


main :: IO ()
main =
    getSessionAddress >>= \case
      Just addr ->
        withSocket addr $ \sock -> do
          send sock (methodCall dbusPath dbusInterface "Hello")
              { methodCallDestination = Just "org.freedesktop.DBus"
              } (\_ser -> return ())
          _ <- receive sock
          bracket connectSession disconnect (app sock)
      Nothing ->
        error
          (mconcat
            [ "DBus session bus address not found; "
            , "is DBUS_SESSION_BUS_ADDRESS set properly?"
            ])

app :: Socket -> Client -> IO ()
app sock client = do
    (captureFinish, awaitCaptureFinish) <- newRelay
    (captureBegin, awaitCaptureBegin) <- newSemaphore
    (daemonJoin, awaitDaemonJoin) <- newRelay
    (daemonPart, awaitDaemonPart) <- newSemaphore
    (daemonStop, awaitDaemonStop) <- newSemaphore

    cGuiPath <- getEnv "FLAMESHOT_CAPTURE_PATH"
    let
        cLogTime = True
        cLogHandle = stderr

    hSetBuffering cLogHandle LineBuffering
    logToTTY <- hIsTerminalDevice cLogHandle
    (putLog, takeLog0) <- newChan

    let
        takeLog1 = if cLogTime then takeLog0 >>= prefixTimestamp else takeLog0
        takeLog2 = showUnprintable <$> takeLog1
        takeLog3 = if logToTTY then takeLog2 else stripSGR <$> takeLog2
        takeLog = takeLog3

    _ <-
      addMatch client matchAny $ \case
        Signal
          { signalPath = "/org/freedesktop/DBus"
          , signalInterface = "org.freedesktop.DBus"
          , signalMember = "NameOwnerChanged"
          , signalSender = Just "org.freedesktop.DBus"
          , signalDestination = Nothing
          , signalBody =
            [ Variant (ValueAtom (AtomText "org.dharkael.Flameshot"))
            , Variant (ValueAtom (AtomText _old_owner))
            , Variant (ValueAtom (AtomText new_owner))
            ]
          }
          ->
            if new_owner /= ""
              then daemonJoin (busName_ (T.unpack new_owner))
              else daemonPart

        Signal
          { signalPath = "/"
          , signalInterface = "org.dharkael.Flameshot"
          , signalDestination = Nothing
          , signalBody = Variant (ValueAtom (AtomWord32 _callId)) : rest
          , ..
          }
          ->
            case signalMember of
              "captureTaken" -> do
                captureFinish (Just rawImage)

              "captureFailed" -> do
                captureFinish Nothing

              _other -> do
                captureFinish Nothing

          where
            [Variant (ValueBytes rawImage)] = rest

        _sig ->
          return ()

    send sock (methodCall dbusPath dbusInterface "AddMatch")
      { methodCallDestination = Just "org.freedesktop.DBus"
      , methodCallBody =
        [ toVariant (T.intercalate ","
                        [ "type='method_call'"
                        , "eavesdrop=true"
                        , "path=/"
                        , "destination=org.dharkael.Flameshot"
                        , "member=graphicCapture"
                        ] )
        ]
      } (\_ser -> return ())

    let
      runDaemon =
        P.run "flameshot" [] Nothing Nothing "" Nothing P.Callbacks
          { P.onOutLine = \_ s -> putLog $ "daemon stdout: " <> Plain s
          , P.onErrLine = \_ s -> putLog $ "daemon stderr: " <> red (Plain s)
          , P.onError = \_ _err -> do
            daemonStop

          , P.onExit = \_ _status -> do
            daemonStop

          , P.onStart = \_ -> return ()
          }
      runGui =
        P.run "flameshot" ["gui", "-p", cGuiPath] Nothing Nothing "" Nothing P.Callbacks
          { P.onOutLine = \_ s -> putLog $ "gui stdout: " <> Plain s
          , P.onErrLine = \_ s -> putLog $ "gui stderr: " <> red (Plain s)
          , P.onError = \_ _err -> return ()
          , P.onExit = \_ _ -> return ()
          , P.onStart = \_ -> return ()
          }
      runReceiver =
        forever $ receive sock >>= \case
          ReceivedMethodCall _ser MethodCall
            { methodCallSender = Just _sender
            , methodCallBody =
              [ Variant (ValueAtom (AtomText _path))
              , Variant (ValueAtom (AtomInt32 _delay))
              , Variant (ValueAtom (AtomWord32 _callId))
              ]
            }
            -> do
            captureBegin

          _received ->
            return ()

      runLogPrinter =
        forever $ takeLog >>= T.hPutStrLn stderr . pp

    let
      withTimeout time f s v io =
          timeout time f >>= \case
            Right x ->
              io x
            Left _time ->
              putLog (s <> " " <> v <> " timeout after " <> blessTime time)

      withTimeout_ time f s v io =
          withTimeout time f s v (const io)

    withThread_ runLogPrinter $ do
      withThread_ runReceiver $ do
        withThread runDaemon $ \daemonThread -> do
          withTimeout 100000 awaitDaemonJoin "daemon" "join" $ \_daemonBusName -> do
            withThread_ runGui $ do
              withTimeout_ 100000 awaitCaptureBegin "gui" "join" $ do
                _maybeRawImage <- awaitCaptureFinish
                return ()

              killThread daemonThread

              withTimeout_ 100000 awaitDaemonPart "daemon" "part" (return ())
              withTimeout_ 100000 awaitDaemonStop "daemon" "stop" (return ())