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

module Flameshot.Internal where

import Blessings.Text
import Control.Concurrent.Async (race)
import Control.Concurrent.Extended
import Control.Exception
import qualified Data.Char as C
import Data.Function (on)
import Data.Maybe (fromMaybe)
import Data.Time.Clock.System
import Data.Time.ISO8601
import DBus
import DBus.Internal.Message
import DBus.Socket
import Data.Text (Text)
import qualified Data.Text.Extended as T
import qualified Flameshot.Internal.Process as P
import System.Exit


blessBusName :: BusName -> Blessings Text
blessBusName = Plain . T.pack . formatBusName

blessMemberName :: MemberName -> Blessings Text
blessMemberName = Plain . T.pack . formatMemberName

blessMethodError :: MethodError -> Blessings Text
blessMethodError err@MethodError{..} =
    red . Plain $ fromMaybe (T.show err) msg
  where
    msg = if length methodErrorBody > 0
            then fromVariant (methodErrorBody !! 0)
            else Nothing

blessShow :: Show a => a -> Blessings Text
blessShow = Plain . T.show

blessTime :: Int -> Blessings Text
blessTime = Plain . (<>"μs") . T.show

red :: Blessings Text -> Blessings Text
red = SGR [31]



withThread :: IO () -> (ThreadId -> IO a) -> IO a
withThread tf wtf =
    bracket (forkIO tf) killThread wtf

withThread_ :: IO () -> IO a -> IO a
withThread_ tf wtf =
    bracket (forkIO tf) killThread (const wtf)


timeout :: Int -> IO a -> IO (Either Int a)
timeout time io =
    race (threadDelay time) io >>= \case
      Right x -> return (Right x)
      Left () -> return (Left time)


dbusInterface :: InterfaceName
dbusInterface = "org.freedesktop.DBus"

withSocket :: Address -> (Socket -> IO a) -> IO a
withSocket addr = bracket (open addr) close


getTimestamp :: IO String
getTimestamp =
    formatISO8601Micros . systemToUTCTime <$> getSystemTime

prefixTimestamp :: Blessings Text -> IO (Blessings Text)
prefixTimestamp s =
    (<> s) . (<>" ") . SGR [38,5,239] . Plain . T.pack <$> getTimestamp

showUnprintable :: Blessings Text -> Blessings Text
showUnprintable =
    fmap' showU
  where
    showU :: Text -> Blessings Text
    showU =
        mconcat
          . map (either Plain (hi . Plain . showLitChars))
          . toEither (not . C.isPrint)

    -- like Blessings' fmap, but don't wrap the Plain case in another Plain
    fmap' :: (Text -> Blessings Text) -> Blessings Text -> Blessings Text
    fmap' f = \case
        Append t1 t2 -> Append (fmap' f t1) (fmap' f t2)
        Plain s -> f s
        SGR pm t -> SGR pm (fmap' f t)
        Empty -> Empty

    hi = SGR [38,5,79]

    showLitChars :: Text -> Text
    showLitChars = T.concatMap (T.pack . flip C.showLitChar "")

    toEither :: (Char -> Bool) -> Text -> [Either Text Text]
    toEither p =
      map (\s -> if p (T.head s) then Right s else Left s)
      . T.groupBy ((==) `on` p)

logger :: (Blessings Text -> IO ()) -> Text -> P.Callbacks
logger putLog name =
    P.Callbacks
      { P.onOutLine = \pid s ->
        putLog' pid $ "stdout: " <> Plain s

      , P.onErrLine = \pid s ->
        putLog' pid $ "stderr: " <> red (Plain s)

      , P.onError = \pid err ->
        putLog' pid $ "error: " <> blessShow err

      , P.onExit = \pid status ->
        case status of
          ExitSuccess ->
            putLog' pid $ "exited"
          ExitFailure code ->
            putLog' pid $ "exited with code " <> red (blessShow code)

      , P.onStart = \pid ->
        putLog' pid "started"
      }
  where
    putLog' pid s = putLog $ Plain name <> "[" <> blessShow pid <> "] " <> s