{-# 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 Data.Int (Int32)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Maybe (fromMaybe)
import Data.Word (Word32)
import DBus
import DBus.Client
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
import System.Random
import Text.Read (readMaybe)


main :: IO ()
main =
    bracket connectSession disconnect app

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

    cGuiPath <- getEnv "FLAMESHOT_CAPTURE_PATH"

    let
        cLogTime = True
        cLogHandle = stderr

    cTimeout <-
      let
        def = 1000
        err = error $ "failed to read integer from " <> var
        var = "FLAMESHOT_ONCE_TIMEOUT"
      in
        (1000*) . maybe def (fromMaybe err . readMaybe) <$> lookupEnv var

    hSetBuffering cLogHandle LineBuffering
    logToTTY <- hIsTerminalDevice cLogHandle
    (putLog0, takeLog) <- newChan

    let
        putLog1 = if cLogTime then (putLog0 =<<) . prefixTimestamp else putLog0
        putLog2 = putLog1 . showUnprintable
        putLog3 = if logToTTY then putLog2 else putLog2 . stripSGR
        putLog = putLog3

    _ <-
      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.flameshot.Flameshot"))
            , Variant (ValueAtom (AtomText _old_owner))
            , Variant (ValueAtom (AtomText new_owner))
            ]
          }
          ->
            if new_owner /= ""
              then daemonJoin
              else daemonPart

        Signal
          { signalPath = "/"
          , signalInterface = "org.flameshot.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), Variant _geometry ] = rest

        _sig ->
          return ()

    let
      copyToClipboard mimetype input =
        P.runAway "xclip" ["-selection", "clipboard", "-t", mimetype, "-i"]
          Nothing Nothing input Nothing $
          logger putLog "xclip"
      runDaemon =
        P.run "flameshot" [] Nothing Nothing "" Nothing $
          logger putLog "daemon" <>
          mempty
            { P.onError = \_ _ -> daemonStop
            , P.onExit = \_ _ -> daemonStop
            }
      runLogPrinter =
        forever $ takeLog >>= T.hPutStrLn stderr . pp
      runWindowWaiter name onQuit = do
        P.run "xwaitforwindow" ["-name", name] Nothing Nothing "" Nothing $
          logger putLog ("xwaitforwindow(name=" <> T.pack (show name) <> ")") <>
          mempty
            { P.onError = \_ _ -> onQuit
            , P.onExit = \_ _ -> onQuit
            }
      waitForWindow name = do
        (waiterStop, awaitWaiterStop) <- newSemaphore
        withThread_ (runWindowWaiter name waiterStop) awaitWaiterStop

    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 runDaemon $ \daemonThread -> do
        withTimeout_ cTimeout awaitDaemonJoin "daemon" "join" $ do
          callId <- getStdRandom random :: IO Word32
          call client (methodCall "/" "" "graphicCapture")
              { methodCallDestination = Just "org.flameshot.Flameshot"
              , methodCallInterface = Nothing
              , methodCallBody =
                [ toVariant cGuiPath
                , toVariant (0 :: Int32)
                , toVariant callId
                ]
              } >>= \case
            Right MethodReturn{} ->
              awaitCaptureFinish >>= mapM_ (copyToClipboard "image/png")

            Left err ->
              putLog $ "capture failed: " <> blessMethodError err

          -- sleep in order give the upload window a chance to appear
          threadDelay cTimeout
          waitForWindow "Upload to Imgur"

          killThread daemonThread

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