    {-# LANGUAGE OverloadedStrings #-}
    -- | This widget listens on DBus for freedesktop notifications
    -- (http://developer.gnome.org/notification-spec/).  Currently it is
    -- somewhat ugly, but the format is somewhat configurable.  A visual
    -- overhaul of the widget is coming.
    --
    -- The widget only displays one notification at a time and
    -- notifications are cancellable.
    module System.Taffybar.FreedesktopNotifications (
      -- * Types
      Notification(..),
      NotificationConfig(..),
      -- * Constructor
      notifyAreaNew,
      defaultNotificationConfig
      ) where

    import Control.Concurrent
    import Control.Monad.Trans ( liftIO )
    import Data.Int ( Int32 )
    import Data.IORef
    import Data.Map ( Map )
    import Data.Monoid ( mconcat )
    import qualified Data.Sequence as S
    import Data.Sequence ( Seq, (|>), viewl, ViewL(..) )
    import Data.Text ( Text )
    import qualified Data.Text as T
    import Data.Word ( Word32 )
    import DBus
    import DBus.Client
    import Graphics.UI.Gtk hiding ( Variant )

    -- | A simple structure representing a Freedesktop notification
    data Notification = Notification { noteAppName :: Text
                                     , noteReplaceId :: Word32
                                     , noteSummary :: Text
                                     , noteBody :: Text
                                     , noteExpireTimeout :: Int32
                                     , noteId :: Word32
                                     }
                        deriving (Show, Eq)

    data WorkType = CancelNote (Maybe Word32)
                  | ReplaceNote Word32 Notification
                  | NewNote
                  | ExpireNote Word32

    data NotifyState = NotifyState { noteQueue :: MVar (Seq Notification)
                                   , noteIdSource :: MVar Word32
                                   , noteWorkerChan :: Chan WorkType
                                   , noteWidget :: Label
                                   , noteContainer :: Widget
                                   , noteTimerThread :: MVar (Maybe ThreadId)
                                   , noteConfig :: NotificationConfig
                                   }

    initialNoteState :: Widget -> Label -> NotificationConfig -> IO NotifyState
    initialNoteState wrapper l cfg = do
      c <- newChan
      m <- newMVar 1
      q <- newMVar S.empty
      t <- newMVar Nothing
      return NotifyState { noteQueue = q
                         , noteIdSource = m
                         , noteWorkerChan = c
                         , noteWidget = l
                         , noteContainer = wrapper
                         , noteTimerThread = t
                         , noteConfig = cfg
                         }

    getServerInformation :: IO (Text, Text, Text, Text)
    getServerInformation =
      return ("haskell-notification-daemon",
              "nochair.net",
              "0.0.1",
              "1.1")

    getCapabilities :: IO [Text]
    getCapabilities = return ["body", "body-markup"]

    closeNotification :: NotifyState -> Word32 -> IO ()
    closeNotification istate nid = do
      -- FIXME: filter anything with this nid out of the queue before
      -- posting to the queue so that the worker doesn't need to scan the
      -- queue
      writeChan (noteWorkerChan istate) (CancelNote (Just nid))

    -- | Apply the user's formatter and truncate the result with the
    -- specified maxlen.
    formatMessage :: NotifyState -> Notification -> String
    formatMessage s = take maxlen . fmt
      where
        maxlen = notificationMaxLength $ noteConfig s
        fmt = notificationFormatter $ noteConfig s

    notify :: MVar Int
              -> NotifyState
              -> Text -- ^ Application name
              -> Word32 -- ^ Replaces id
              -> Text -- ^ App icon
              -> Text -- ^ Summary
              -> Text -- ^ Body
              -> [Text] -- ^ Actions
              -> Map Text Variant -- ^ Hints
              -> Int32 -- ^ Expires timeout (milliseconds)
              -> IO Word32
    notify idSrc istate appName replaceId icon summary body actions hints timeout = do
      let maxtout = fromIntegral $ notificationMaxTimeout (noteConfig istate)
          tout = case timeout of
            0 -> maxtout
            (-1) -> maxtout
            _ -> min maxtout timeout
      case replaceId of
        0 -> do
          nid <- modifyMVar idSrc (\x -> return (x+1, x))
          let n = Notification { noteAppName = appName
                               , noteReplaceId = 0
                               , noteSummary = T.pack $ escapeMarkup $ T.unpack summary
                               , noteBody = T.pack $ escapeMarkup $ T.unpack body
                               , noteExpireTimeout = tout
                               , noteId = fromIntegral nid
                               }
          modifyMVar_ (noteQueue istate) (\x -> return (x |> n))
          writeChan (noteWorkerChan istate) NewNote
          return (fromIntegral nid)
        i -> do
          let n = Notification { noteAppName = appName
                               , noteReplaceId = i
                               , noteSummary = summary
                               , noteBody = body
                               , noteExpireTimeout = tout
                               , noteId = i
                               }
          -- First, replace any notes in the note queue with this note, if
          -- applicable.  Next, notify the worker and have it replace the
          -- current note if that note has this id.
          modifyMVar_ (noteQueue istate) (\q -> return $ fmap (replaceNote i n) q)
          writeChan (noteWorkerChan istate) (ReplaceNote i n)
          return i

    replaceNote :: Word32 -> Notification -> Notification -> Notification
    replaceNote nid newNote curNote =
      case noteId curNote == nid of
        False -> curNote
        True -> newNote

    notificationDaemon onNote onCloseNote = do
      client <- connectSession
      _ <- requestName client "org.freedesktop.Notifications" [nameAllowReplacement, nameReplaceExisting]
      export client "/org/freedesktop/Notifications"
        [ autoMethod "org.freedesktop.Notifications" "GetServerInformation" getServerInformation
        , autoMethod "org.freedesktop.Notifications" "GetCapabilities" getCapabilities
        , autoMethod "org.freedesktop.Notifications" "CloseNotification" onCloseNote
        , autoMethod "org.freedesktop.Notifications" "Notify" onNote
        ]

    -- When a notification is received, add it to the queue.  Post a token to the channel that the
    -- worker blocks on.

    -- The worker thread should sit idle waiting on a chan read.  When it
    -- wakes up, check to see if the current notification needs to be
    -- expired (due to a cancellation) or just expired on its own.  If it
    -- expired on its own, just empty it out and post the next item in the
    -- queue, if any.  If posting, start a thread that just calls
    -- theadDelay for the lifetime of the notification.

    workerThread :: NotifyState -> IO ()
    workerThread s = do
      currentNote <- newIORef Nothing
      workerThread' currentNote
      where
        workerThread' currentNote = do
          work <- readChan (noteWorkerChan s)
          case work of
            NewNote -> onNewNote currentNote
            ReplaceNote nid n -> onReplaceNote currentNote nid n
            CancelNote Nothing -> userCancelNote currentNote
            CancelNote nid -> do
              workerThread' currentNote
            ExpireNote nid -> expireNote currentNote nid
        -- | The user closed the notification manually
        userCancelNote currentNote = do
          writeIORef currentNote Nothing
          postGUIAsync $ widgetHideAll (noteContainer s)
          showNextNoteIfAny currentNote

        onReplaceNote currentNote nid n = do
          cnote <- readIORef currentNote
          case cnote of
            Nothing -> do
              writeIORef currentNote (Just n)
              postGUIAsync $ do
                labelSetMarkup (noteWidget s) (formatMessage s n)
                widgetShowAll (noteContainer s)
              timerThreadId <- forkIO $ setExpireTimeout (noteWorkerChan s) (noteId n) (noteExpireTimeout n)
              modifyMVar_ (noteTimerThread s) $ const (return (Just timerThreadId))
              workerThread' currentNote
            Just cnote' -> case noteId cnote' == nid of
              -- The replaced note was not current and it either does not
              -- exist or it was already replaced in the note queue
              False -> workerThread' currentNote
              -- Otherwise, swap out the current note
              True -> do
                withMVar (noteTimerThread s) (maybe (return ()) killThread)
                writeIORef currentNote (Just n)
                postGUIAsync $ labelSetMarkup (noteWidget s) (formatMessage s n)
                timerId <- forkIO $ setExpireTimeout (noteWorkerChan s) (noteId n) (noteExpireTimeout n)
                modifyMVar_ (noteTimerThread s) $ const $ return (Just timerId)
                workerThread' currentNote

        -- | If the current note has the ID being expired, clear the
        -- notification area and see if there is a pending note to post.
        expireNote currentNote nid = do
          cnote <- readIORef currentNote
          case cnote of
            Nothing -> showNextNoteIfAny currentNote
            Just cnote' ->
              case noteId cnote' == nid of
                False -> workerThread' currentNote -- Already expired
                True -> do
                  -- Drop the reference and clear the notification area
                  -- before trying to show a new note
                  writeIORef currentNote Nothing
                  postGUIAsync $ widgetHideAll (noteContainer s)
                  showNextNoteIfAny currentNote

        onNewNote currentNote = do
          maybeCurrent <- readIORef currentNote
          case maybeCurrent of
            Nothing -> showNextNoteIfAny currentNote
              -- Grab the next note, show it, and then start a timer
            Just note -> do
              -- Otherwise, the current note isn't expired yet and we need
              -- to wait for it.
              workerThread' currentNote

        -- For use when there is no current note, attempt to show the next
        -- node and then block to wait for the next event.  This is
        -- guarded by a postGUIAsync.
        showNextNoteIfAny noCurrentNote = do
          nextNote <- modifyMVar (noteQueue s) takeNote
          case nextNote of
            Nothing -> workerThread' noCurrentNote
            Just nextNote' -> do
              writeIORef noCurrentNote nextNote
              postGUIAsync $ do
                labelSetMarkup (noteWidget s) (formatMessage s nextNote')
                widgetShowAll (noteContainer s)
              timerThreadId <- forkIO $ setExpireTimeout (noteWorkerChan s) (noteId nextNote') (noteExpireTimeout nextNote')
              modifyMVar_ (noteTimerThread s) $ const (return (Just timerThreadId))
              workerThread' noCurrentNote

    takeNote :: Monad m => Seq a -> m (Seq a, Maybe a)
    takeNote q =
      case viewl q of
        EmptyL -> return (q, Nothing)
        n :< rest -> return (rest, Just n)

    setExpireTimeout :: Chan WorkType -> Word32 -> Int32 -> IO ()
    setExpireTimeout c nid seconds = do
      threadDelay (fromIntegral seconds * 1000000)
      writeChan c (ExpireNote nid)

    userCancel s = do
      liftIO $ writeChan (noteWorkerChan s) (CancelNote Nothing)
      return True

    data NotificationConfig =
      NotificationConfig { notificationMaxTimeout :: Int -- ^ Maximum time that a notification will be displayed (in seconds).  Default: 10
                         , notificationMaxLength :: Int  -- ^ Maximum length displayed, in characters.  Default: 50
                         , notificationFormatter :: Notification -> String -- ^ Function used to format notifications
                         }

    defaultFormatter :: Notification -> String
    defaultFormatter note = msg
      where
        msg = case T.null (noteBody note) of
          True -> T.unpack $ noteSummary note
          False -> T.unpack $ mconcat [ "<span fgcolor='yellow'>Note:</span>"
                                      , noteSummary note, ": ", noteBody note ]

    -- | The default formatter is one of
    --
    -- * Summary : Body
    --
    -- * Summary
    --
    -- depending on the presence of a notification body.
    defaultNotificationConfig :: NotificationConfig
    defaultNotificationConfig =
      NotificationConfig { notificationMaxTimeout = 10
                         , notificationMaxLength = 100
                         , notificationFormatter = defaultFormatter
                         }

    -- | Create a new notification area with the given configuration.
    notifyAreaNew :: NotificationConfig -> IO Widget
    notifyAreaNew cfg = do
      frame <- frameNew
      box <- hBoxNew False 3
      textArea <- labelNew Nothing
      button <- eventBoxNew
      sep <- vSeparatorNew

      buttonLabel <- labelNew Nothing
      widgetSetName buttonLabel "NotificationCloseButton"
      buttonStyle <- rcGetStyle buttonLabel
      buttonTextColor <- styleGetText buttonStyle StateNormal
      labelSetMarkup buttonLabel "×"

      labelSetMaxWidthChars textArea (notificationMaxLength cfg)
      labelSetEllipsize textArea EllipsizeEnd

      containerAdd button buttonLabel
      boxPackStart box textArea PackGrow 0
      boxPackStart box sep PackNatural 0
      boxPackStart box button PackNatural 0

      containerAdd frame box

      widgetHideAll frame

      istate <- initialNoteState (toWidget frame) textArea cfg
      _ <- on button buttonReleaseEvent (userCancel istate)
      _ <- forkIO (workerThread istate)

      -- This is only available to the notify handler, so it doesn't need
      -- to be protected from the worker thread.  There might be multiple
      -- notifiation handler threads, though (not sure), so keep it safe
      -- and use an mvar.
      idSrc <- newMVar 1

      realizableWrapper <- hBoxNew False 0
      boxPackStart realizableWrapper frame PackNatural 0
      widgetShow realizableWrapper

      -- We can't start the dbus listener thread until we are in the GTK
      -- main loop, otherwise things are prone to lock up and block
      -- infinitely on an mvar.  Bad stuff - only start the dbus thread
      -- after the fake invisible wrapper widget is realized.
      on realizableWrapper realize $ notificationDaemon (notify idSrc istate) (closeNotification istate)

      -- Don't show ib by default - it will appear when needed
      return (toWidget realizableWrapper)