{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}

module StatusNotifier.Host.Service where

import           Control.Arrow
import           Control.Concurrent
import           Control.Concurrent.MVar
import           Control.Lens
import           Control.Lens.Tuple
import           Control.Monad
import           Control.Monad.Except
import           DBus
import           DBus.Client
import qualified DBus.Internal.Message as M
import qualified Data.ByteString as BS
import           Data.Either
import           Data.Int
import qualified Data.Map.Strict as Map
import           Data.Maybe
import           Data.String
import           Data.Word
import           System.Log.Logger
import           Text.Printf

import qualified StatusNotifier.Item.Constants as I
import qualified StatusNotifier.Item.Client as I
import           StatusNotifier.Util
import qualified StatusNotifier.Watcher.Client as W
import qualified StatusNotifier.Watcher.Signals as W

statusNotifierHostString :: String
statusNotifierHostString = "StatusNotifierHost"

getBusName :: String -> String -> String
getBusName namespace =
  printf "%s.%s-%s" namespace statusNotifierHostString

data UpdateType
  = ItemAdded
  | ItemRemoved
  | IconUpdated
  | IconNameUpdated
  | TitleUpdated
  | TooltipUpdated deriving (Eq, Show)

data Params = Params
  { dbusClient :: Maybe Client
  , uniqueIdentifier :: String
  , namespace :: String
  , handleUpdate :: UpdateType -> ItemInfo -> IO ()
  , hostLogger :: Logger
  }

defaultParams = Params
  { dbusClient = Nothing
  , uniqueIdentifier = ""
  , namespace = "org.kde"
  , handleUpdate = \_ _ -> return ()
  , hostLogger = makeDefaultLogger "StatusNotifier.Watcher.Service"
  }

data ItemInfo = ItemInfo
  { itemServiceName :: BusName
  , itemServicePath :: ObjectPath
  , iconTitle :: String
  , iconName :: String
  , iconThemePath :: Maybe String
  , iconPixmaps :: [(Int32, Int32, BS.ByteString)]
  , menuPath :: Maybe ObjectPath
  } deriving (Eq, Show)

defaultItemInfo =
  ItemInfo
  { itemServiceName = "a.b"
  , itemServicePath = "/"
  , iconThemePath = Nothing
  , iconName = ""
  , iconTitle = ""
  , iconPixmaps = []
  , menuPath = Nothing
  }

makeLensesWithLSuffix ''ItemInfo

convertPixmapsToHostByteOrder ::
  [(Int32, Int32, BS.ByteString)] -> [(Int32, Int32, BS.ByteString)]
convertPixmapsToHostByteOrder = map $ over _3 networkToSystemByteOrder

callFromInfo fn ItemInfo { itemServiceName = name
                         , itemServicePath = path
                         } = fn name path

build :: Params -> IO (IO RequestNameReply)
build Params { dbusClient = mclient
             , namespace = namespaceString
             , uniqueIdentifier = uniqueID
             , handleUpdate = updateHandler
             , hostLogger = logger
             } = do
  client <- maybe connectSession return mclient
  itemInfoMapVar <- newMVar Map.empty
  let busName = getBusName namespaceString uniqueID

      logError = logL logger ERROR
      logErrorWithMessage message error = logError message >> logError (show error)
      logInfo = logL logger INFO
      logErrorAndThen andThen e = logError (show e) >> andThen

      doUpdate utype uinfo =
        logInfo (printf "Sending update (iconPixmaps suppressed): %s %s"
                          (show utype)
                          (show $ uinfo { iconPixmaps = [] })) >>
        void (forkIO (updateHandler utype uinfo))

      getPixmaps a1 a2 a3 = fmap convertPixmapsToHostByteOrder <$>
                            I.getIconPixmap a1 a2 a3

      buildItemInfo name = runExceptT $ do
        pathString <- ExceptT $ W.getObjectPathForItemName client name
        let busName = fromString name
            path = objectPath_ pathString
            getMaybe fn a b c = right Just <$> fn a b c
            doGetDef def fn =
              ExceptT $ exemptAll def <$> fn client busName path
            doGet fn = ExceptT $ fn client busName path
        pixmaps <- doGetDef [] getPixmaps
        iName <- doGetDef name I.getIconName
        themePath <- doGetDef Nothing $ getMaybe I.getIconThemePath
        menu <- doGetDef Nothing $ getMaybe I.getMenu
        title <- doGetDef "" I.getTitle
        return ItemInfo
                 { itemServiceName = busName_ name
                 , itemServicePath = path
                 , iconPixmaps = pixmaps
                 , iconThemePath = themePath
                 , iconName = iName
                 , iconTitle = title
                 , menuPath = menu
                 }

      createAll serviceNames = do
        (errors, itemInfos) <-
          partitionEithers <$> mapM buildItemInfo serviceNames
        mapM_ (logErrorWithMessage "Error in item building at startup:") errors
        return itemInfos

      registerWithPairs =
        mapM (uncurry clientSignalRegister)
        where logUnableToCallSignal signal =
                logL logger ERROR $ printf "Unable to call handler with %s" $
                     show signal
              clientSignalRegister signalRegisterFn handler =
                signalRegisterFn client matchAny handler logUnableToCallSignal

      handleItemAdded _ serviceName =
        modifyMVar_ itemInfoMapVar $ \itemInfoMap ->
          buildItemInfo serviceName >>=
                        either (logErrorAndThen $ return itemInfoMap)
                                 (addItemInfo itemInfoMap)
          where addItemInfo map itemInfo = doUpdate ItemAdded itemInfo >>
                  return (Map.insert (itemServiceName itemInfo) itemInfo map)

      getObjectPathForItemName name =
        maybe I.defaultPath itemServicePath . Map.lookup name <$>
        readMVar itemInfoMapVar

      handleItemRemoved _ serviceName = let busName = busName_ serviceName in
        modifyMVar_ itemInfoMapVar (return . Map.delete busName ) >>
        doUpdate ItemRemoved defaultItemInfo { itemServiceName = busName }

      watcherRegistrationPairs =
        [ (W.registerForStatusNotifierItemRegistered, handleItemAdded)
        , (W.registerForStatusNotifierItemUnregistered, handleItemRemoved)
        ]

      getSender fn s@M.Signal { M.signalSender = Just sender} =
        logInfo (show s) >> fn sender
      getSender _ s = logError $ "Received signal with no sender: " ++ show s

      logPropError = logErrorWithMessage "Error updating property: "

      makeUpdaterFromProp = makeUpdaterFromProp' logPropError

      makeUpdaterFromProp' onError lens updateType prop = getSender run
        where run sender =
                getObjectPathForItemName sender >>=
                prop client sender >>=
                either onError (runUpdate lens updateType sender)

      runUpdate lens updateType sender newValue =
        modifyMVar itemInfoMapVar modify >>= callUpdate
          where modify infoMap =
                  let newMap = set (at sender . non defaultItemInfo . lens)
                               newValue infoMap
                  in return (newMap, Map.lookup sender newMap)
                callUpdate = flip whenJust (doUpdate updateType)

      updatePixmaps =
        makeUpdaterFromProp iconPixmapsL IconUpdated getPixmaps
      handleNewIcon signal =
        makeUpdaterFromProp'
        (const $ updatePixmaps signal)
        iconNameL IconNameUpdated I.getIconName signal
      handleNewTitle =
        makeUpdaterFromProp iconTitleL TitleUpdated I.getTitle

      clientRegistrationPairs =
        [ (I.registerForNewIcon, handleNewIcon)
        , (I.registerForNewTitle, handleNewTitle)
        ]

      initializeItemInfoMap = modifyMVar_ itemInfoMapVar $ \itemInfoMap -> do
        -- All initialization is done inside this modifyMvar to avoid race
        -- conditions with the itemInfoMapVar.
        clientSignalHandlers <- registerWithPairs clientRegistrationPairs
        watcherSignalHandlers <- registerWithPairs watcherRegistrationPairs
        let unregisterAll =
                mapM_ (removeMatch client) $
                    clientSignalHandlers ++ watcherSignalHandlers
            shutdownHost = do
                logInfo "Shutting down StatusNotifierHost"
                unregisterAll
                releaseName client (fromString busName)
                return ()
            logErrorAndShutdown error =
              logError (show error) >> shutdownHost >> return Map.empty
            finishInitialization serviceNames = do
              itemInfos <- createAll serviceNames
              mapM_ (doUpdate ItemAdded) itemInfos
              let newMap = Map.fromList $ map (itemServiceName &&& id) itemInfos
                  -- Extra paranoia about the map
                  resultMap = if Map.null itemInfoMap
                              then newMap
                              else Map.union itemInfoMap newMap
              W.registerStatusNotifierHost client busName >>=
               either logErrorAndShutdown (const $ return resultMap)
        W.getRegisteredStatusNotifierItems client >>=
         either logErrorAndShutdown finishInitialization

      startup =
        do
          nameRequestResult <- requestName client (fromString busName) []
          when (nameRequestResult == NamePrimaryOwner) initializeItemInfoMap
          return nameRequestResult
  return startup