{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE RecordWildCards   #-}

-----------------------------------------------------------------------------
-- |
-- Copyright   :  (c) riskbook, 2020
-- SPDX-License-Identifier:  BSD3
--
-----------------------------------------------------------------------------
module Network.XMPP.XEP.MAM
  ( messageArchiveQueryStanza
  , defMamQuery
  , MAMQuery(..)
  , MAMPayload(..)
  ) where

import qualified Data.UUID              as UUID
import           Data.Time              (UTCTime)
import           Data.Text              (Text, pack)
import           Data.Maybe             (catMaybes)

import           Text.Hamlet.XML        (xml)

import           Network.XMPP.Types
import           Network.XMPP.XML       (ToXML(..), FromXML(..), matchPatterns,
                                         txtpat, mread)
import           Network.XMPP.XEP.Form  (XmppForm(..), XmppField(..))

--
-- Messaging archives management extenstion
-- https://xmpp.org/extensions/xep-0313.html#query
--

messageArchiveQueryStanza :: MAMQuery -> UUID.UUID -> Stanza 'IQ 'Outgoing ()
messageArchiveQueryStanza :: MAMQuery -> UUID -> Stanza 'IQ 'Outgoing ()
messageArchiveQueryStanza MAMQuery {Bool
Int
Maybe Text
Maybe UTCTime
Maybe (JID 'Node)
mqFromLatest :: MAMQuery -> Bool
mqBefore :: MAMQuery -> Maybe Text
mqAfter :: MAMQuery -> Maybe Text
mqLimit :: MAMQuery -> Int
mqRoom :: MAMQuery -> Maybe (JID 'Node)
mqWith :: MAMQuery -> Maybe (JID 'Node)
mqEnd :: MAMQuery -> Maybe UTCTime
mqStart :: MAMQuery -> Maybe UTCTime
mqFromLatest :: Bool
mqBefore :: Maybe Text
mqAfter :: Maybe Text
mqLimit :: Int
mqRoom :: Maybe (JID 'Node)
mqWith :: Maybe (JID 'Node)
mqEnd :: Maybe UTCTime
mqStart :: Maybe UTCTime
..} UUID
uuid =
  let form :: XmppForm
form = [XmppField] -> XmppForm
XmppForm ([XmppField] -> XmppForm) -> [XmppField] -> XmppForm
forall a b. (a -> b) -> a -> b
$ [Maybe XmppField] -> [XmppField]
forall a. [Maybe a] -> [a]
catMaybes
        [ XmppField -> Maybe XmppField
forall a. a -> Maybe a
Just (XmppField -> Maybe XmppField) -> XmppField -> Maybe XmppField
forall a b. (a -> b) -> a -> b
$ Text -> Text -> XmppField
HiddenField Text
"FORM_TYPE" Text
"urn:xmpp:mam:2"
        , Text -> Text -> XmppField
SingleTextField Text
"with" (Text -> XmppField)
-> (JID 'Node -> Text) -> JID 'Node -> XmppField
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Text) -> (JID 'Node -> String) -> JID 'Node -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JID 'Node -> String
forall a. Show a => a -> String
show (JID 'Node -> XmppField) -> Maybe (JID 'Node) -> Maybe XmppField
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (JID 'Node)
mqWith
        , Text -> Text -> XmppField
SingleTextField Text
"start" (Text -> XmppField) -> (UTCTime -> Text) -> UTCTime -> XmppField
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Text) -> (UTCTime -> String) -> UTCTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> String
forall a. Show a => a -> String
show (UTCTime -> XmppField) -> Maybe UTCTime -> Maybe XmppField
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UTCTime
mqStart
        , Text -> Text -> XmppField
SingleTextField Text
"end" (Text -> XmppField) -> (UTCTime -> Text) -> UTCTime -> XmppField
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Text) -> (UTCTime -> String) -> UTCTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> String
forall a. Show a => a -> String
show (UTCTime -> XmppField) -> Maybe UTCTime -> Maybe XmppField
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UTCTime
mqEnd
        ]
  in  MkIQ :: forall (p :: StanzaPurpose) ext.
Maybe SomeJID
-> Maybe SomeJID
-> Text
-> IQType
-> DataByPurpose p ext
-> Sing p
-> Stanza 'IQ p ext
MkIQ { iqFrom :: Maybe SomeJID
iqFrom = Maybe SomeJID
forall a. Maybe a
Nothing
           , iqTo :: Maybe SomeJID
iqTo   = JID 'Node -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID (JID 'Node -> SomeJID) -> Maybe (JID 'Node) -> Maybe SomeJID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (JID 'Node)
mqRoom
           , iqId :: Text
iqId   = UUID -> Text
UUID.toText UUID
uuid
           , iqType :: IQType
iqType = IQType
Set
           , iqPurpose :: Sing 'Outgoing
iqPurpose = Sing 'Outgoing
SOutgoing
           , iqBody :: DataByPurpose 'Outgoing ()
iqBody = [xml| 
              <query xmlns="urn:xmpp:mam:2">
                ^{encodeXml form}

                <set xmlns="http://jabber.org/protocol/rsm">
                  <max>#{pack $ show mqLimit}
                  $maybe afterId <- mqAfter
                    <after>#{afterId}

                  $if mqFromLatest
                    <before>
                      $maybe beforeId <- mqBefore
                        #{beforeId}
                  $else
                    $maybe beforeId <- mqBefore
                      <before>#{beforeId}
            |]
          }

data MAMQuery = MAMQuery
  { MAMQuery -> Maybe UTCTime
mqStart :: Maybe UTCTime
  , MAMQuery -> Maybe UTCTime
mqEnd   :: Maybe UTCTime
  , MAMQuery -> Maybe (JID 'Node)
mqWith  :: Maybe (JID 'Node)
  , MAMQuery -> Maybe (JID 'Node)
mqRoom  :: Maybe (JID 'Node)
  , MAMQuery -> Int
mqLimit :: Int
  , MAMQuery -> Maybe Text
mqAfter :: Maybe Text
  , MAMQuery -> Maybe Text
mqBefore :: Maybe Text
  , MAMQuery -> Bool
mqFromLatest :: Bool
  } deriving (Int -> MAMQuery -> ShowS
[MAMQuery] -> ShowS
MAMQuery -> String
(Int -> MAMQuery -> ShowS)
-> (MAMQuery -> String) -> ([MAMQuery] -> ShowS) -> Show MAMQuery
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MAMQuery] -> ShowS
$cshowList :: [MAMQuery] -> ShowS
show :: MAMQuery -> String
$cshow :: MAMQuery -> String
showsPrec :: Int -> MAMQuery -> ShowS
$cshowsPrec :: Int -> MAMQuery -> ShowS
Show)

defMamQuery :: MAMQuery
defMamQuery :: MAMQuery
defMamQuery = MAMQuery :: Maybe UTCTime
-> Maybe UTCTime
-> Maybe (JID 'Node)
-> Maybe (JID 'Node)
-> Int
-> Maybe Text
-> Maybe Text
-> Bool
-> MAMQuery
MAMQuery
  { mqStart :: Maybe UTCTime
mqStart = Maybe UTCTime
forall a. Maybe a
Nothing
  , mqEnd :: Maybe UTCTime
mqEnd   = Maybe UTCTime
forall a. Maybe a
Nothing
  , mqWith :: Maybe (JID 'Node)
mqWith  = Maybe (JID 'Node)
forall a. Maybe a
Nothing
  , mqRoom :: Maybe (JID 'Node)
mqRoom  = Maybe (JID 'Node)
forall a. Maybe a
Nothing
  , mqLimit :: Int
mqLimit = Int
10
  , mqAfter :: Maybe Text
mqAfter = Maybe Text
forall a. Maybe a
Nothing
  , mqBefore :: Maybe Text
mqBefore = Maybe Text
forall a. Maybe a
Nothing
  , mqFromLatest :: Bool
mqFromLatest = Bool
False
  }

data MAMPayload = MAMFinalPayload
  { MAMPayload -> Bool
mComplete :: Bool
  , MAMPayload -> Text
mLast     :: Text
  , MAMPayload -> Text
mFirst    :: Text
  , MAMPayload -> Text
mFirstIdx :: Text
  , MAMPayload -> Int
mCount    :: Int
  } deriving (Int -> MAMPayload -> ShowS
[MAMPayload] -> ShowS
MAMPayload -> String
(Int -> MAMPayload -> ShowS)
-> (MAMPayload -> String)
-> ([MAMPayload] -> ShowS)
-> Show MAMPayload
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MAMPayload] -> ShowS
$cshowList :: [MAMPayload] -> ShowS
show :: MAMPayload -> String
$cshow :: MAMPayload -> String
showsPrec :: Int -> MAMPayload -> ShowS
$cshowsPrec :: Int -> MAMPayload -> ShowS
Show)

instance FromXML MAMPayload where
  decodeXml :: Content Posn -> Maybe MAMPayload
decodeXml Content Posn
m
    | Content Posn -> [Text] -> Bool
forall i. Content i -> [Text] -> Bool
matchPatterns Content Posn
m [Text
"/fin/@complete", Text
"/fin/set/count"]
    = Bool -> Text -> Text -> Text -> Int -> MAMPayload
MAMFinalPayload
      (Bool -> Text -> Text -> Text -> Int -> MAMPayload)
-> Maybe Bool -> Maybe (Text -> Text -> Text -> Int -> MAMPayload)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Bool
forall a. (Eq a, IsString a) => a -> Maybe Bool
decodeBool (Text -> Content Posn -> Text
txtpat Text
"/fin/@complete" Content Posn
m)
      Maybe (Text -> Text -> Text -> Int -> MAMPayload)
-> Maybe Text -> Maybe (Text -> Text -> Int -> MAMPayload)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Content Posn -> Text
txtpat Text
"/fin/set/last/-" Content Posn
m)
      Maybe (Text -> Text -> Int -> MAMPayload)
-> Maybe Text -> Maybe (Text -> Int -> MAMPayload)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Content Posn -> Text
txtpat Text
"/fin/set/first/-" Content Posn
m)
      Maybe (Text -> Int -> MAMPayload)
-> Maybe Text -> Maybe (Int -> MAMPayload)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Content Posn -> Text
txtpat Text
"/fin/set/first@index" Content Posn
m)
      Maybe (Int -> MAMPayload) -> Maybe Int -> Maybe MAMPayload
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Maybe Int
forall a. Read a => Text -> Maybe a
mread (Text -> Content Posn -> Text
txtpat Text
"/fin/set/count/-" Content Posn
m)
    | Bool
otherwise
    = Maybe MAMPayload
forall a. Maybe a
Nothing
    where
      decodeBool :: a -> Maybe Bool
decodeBool a
"true"  = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
      decodeBool a
"false" = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
      decodeBool a
_       = Maybe Bool
forall a. Maybe a
Nothing