lens updates

pontarius-xmpp.cabal

@@ -68,6 +68,8 @@ Library
                , xml-conduit          >=1.1.0.7
                , xml-picklers         >=0.3.3
                , x509-system          >=1.4
+               , profunctors          >= 4
+               , lens-family
 
   If impl(ghc ==7.0.1) {
     Build-Depends: bytestring         >=0.9.1.9 && <=0.9.2.1

source/Network/Xmpp/IM/Presence.hs

@@ -53,6 +53,7 @@ xpIMPresence = xpUnliftElems .
                xp3Tuple
                   (xpOption $ xpElemNodes "{jabber:client}show"
                      (xpContent xpShow))
+                  -- TODO: Multiple status elements with different lang tags
                   (xpOption $ xpElemNodes "{jabber:client}status"
                      (xpContent xpText))
                   (xpOption $ xpElemNodes "{jabber:client}priority"

source/Network/Xmpp/IM/Roster.hs

@@ -78,9 +78,13 @@ rosterRemove j sess = do
         let el = pickleElem xpQuery (Query Nothing [fromItem item])
         sendIQA' timeout Nothing Set Nothing el [] session
 
+-- | Retrieve the current Roster state (STM version)
+getRoster' :: Session -> STM Roster
+getRoster' session = readTVar (rosterRef session)
+
 -- | Retrieve the current Roster state
 getRoster :: Session -> IO Roster
-getRoster session = atomically $ readTVar (rosterRef session)
+getRoster session = atomically $ getRoster' session
 
 -- | Get the initial roster or refresh the roster. You don't need to call this
 -- on your own.

source/Network/Xmpp/Lens.hs

@@ -5,20 +5,32 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FunctionalDependencies #-}
 
--- | Van Laarhoven lenses for XMPP types. The lenses are designed to work with
+-- | (More than just) Van Laarhoven lenses for XMPP types. The accessors in here
--- the lens library. This module also provides a few simple accessors ('view',
+-- are designed to work with an optics library like lens or lens-family. This
--- 'modify', 'set' and 'getAll') so you don't need to pull in the
+-- module also provides a few simple functions ('view', 'modify', 'set' and
--- lens library to get some use out of them.
+-- 'getAll') so you don't need to pull in another library to get some use out
+-- of them.
 --
--- The name of the lenses corresponds to the field name of the data types with
+-- * The name of the lenses corresponds to the field name of the data types with
 -- an upper-case L appended. For documentation of the fields refer to the documentation of the data types (linked in the section header)
+--
+-- * Same goes for Traversals, except they are suffixed with a \'T\'
+--
+-- * Prism generally start with an underscore
+--
+-- /NB/ you do not need to import this module to get access to the optics
+-- defined herein. They are also exported from Network.Xmpp. You only need to
+-- import this module if you want to use the complementary accessor functions
+-- without using an optics library like lens or lens-family
 
 module Network.Xmpp.Lens
        ( Lens
        , Traversal
+       , Prism
+       , Iso
          -- * Accessors
          -- | Reimplementation of the basic lens functions so you don't have to
-         -- bring in all of lens library in to use the lenses
+         -- bring in a lens library to use the optics
 
          -- ** Lenses
        , view
@@ -26,9 +38,27 @@ module Network.Xmpp.Lens
        , set
          -- * Traversals
        , getAll
+         -- * Prisms
+
+         -- ** Construction
+       , prism'
+       , mkLens
+
          -- * Lenses
 
+         -- ** JID
+       , _JidText
+       , _isFull
+       , _isBare
+
          -- ** Stanzas
+       , _IQRequest
+       , _IQResult
+       , _IQError
+       , _Message
+       , _MessageError
+       , _Presence
+       , _PresenceError
        , IsStanza(..)
        , HasStanzaPayload(..)
        , IsErrorStanza(..)
@@ -109,10 +139,12 @@ module Network.Xmpp.Lens
        where
 
 import           Control.Applicative
+import qualified Data.ByteString as BS
 import           Data.Functor.Identity (Identity(..))
 import qualified Data.Map as Map
-import qualified Data.Text as Text
+import           Data.Profunctor
 import           Data.Text (Text)
+import qualified Data.Text as Text
 import           Data.XML.Types (Element)
 import           Network.DNS (ResolvConf)
 import           Network.TLS as TLS
@@ -121,13 +153,25 @@ import           Network.Xmpp.IM.Message
 import           Network.Xmpp.IM.Presence
 import           Network.Xmpp.IM.Roster.Types
 import           Network.Xmpp.Types
-import qualified Data.ByteString as BS
 
 -- | Van-Laarhoven lenses.
 type Lens a b = Functor f => (b -> f b) -> a -> f a
 
 type Traversal a b = Applicative f => (b -> f b) -> a -> f a
 
+type Prism a b = forall p f. (Choice p, Applicative f) => p b (f b) -> p a (f a)
+
+type Iso a b = forall p f. (Profunctor p, Functor f) => p a (f a) -> p b (f b)
+
+prism' :: (b -> s) -> (s -> Maybe b) -> Prism s b
+prism' bs sma = dimap (\s -> maybe (Left s) Right (sma s))
+                      (either pure (fmap bs)) . right'
+
+mkLens :: (a -> b) -> (b -> a ->  a) -> Lens a b
+mkLens get set = \inj x -> fmap (flip set x) (inj $ get x)
+
+mkIso :: (a -> b) -> (b -> a) -> Iso a b
+mkIso to from = dimap from (fmap to)
 
 -- Accessors
 ---------------
@@ -154,10 +198,18 @@ instance Applicative (Collect a) where
 getAll :: Traversal a b -> a -> [b]
 getAll t = getCollection . t (Collect . pure)
 
-
 -- Xmpp Lenses
 --------------------
 
+_JidText :: Prism Text Jid
+_JidText = prism' jidToText jidFromText
+
+_isFull :: Prism Jid Jid
+_isFull = prism' id (\j -> if isFull j then Just j else Nothing)
+
+_isBare :: Prism Jid Jid
+_isBare = prism' toBare (\j -> if isBare j then Just j else Nothing)
+
 class IsStanza s where
     -- | From-attribute of the stanza
     from :: Lens s (Maybe Jid)
@@ -288,6 +340,48 @@ maybeNonempty inj x = (maybe Text.empty id)
                       <$> inj (if Text.null x then Nothing else Just x)
 
 
+_IQRequest :: Prism Stanza IQRequest
+_IQRequest = prism' IQRequestS fromIQRequestS
+  where
+    fromIQRequestS (IQRequestS s) = Just s
+    fromIQRequestS _ = Nothing
+
+_IQResult :: Prism Stanza IQResult
+_IQResult = prism' IQResultS fromIQResultS
+  where
+    fromIQResultS (IQResultS s) = Just s
+    fromIQResultS _ = Nothing
+
+_IQError :: Prism Stanza IQError
+_IQError = prism' IQErrorS fromIQErrorS
+  where
+    fromIQErrorS (IQErrorS s) = Just s
+    fromIQErrorS _ = Nothing
+
+_Message :: Prism Stanza Message
+_Message = prism' MessageS fromMessageS
+  where
+    fromMessageS (MessageS s) = Just s
+    fromMessageS _ = Nothing
+
+_MessageError :: Prism Stanza MessageError
+_MessageError = prism' MessageErrorS fromMessageErrorS
+  where
+    fromMessageErrorS (MessageErrorS s) = Just s
+    fromMessageErrorS _ = Nothing
+
+_Presence :: Prism Stanza Presence
+_Presence = prism' PresenceS fromPresenceS
+  where
+    fromPresenceS (PresenceS s) = Just s
+    fromPresenceS _ = Nothing
+
+_PresenceError :: Prism Stanza PresenceError
+_PresenceError = prism' PresenceErrorS fromPresenceErrorS
+  where
+    fromPresenceErrorS (PresenceErrorS s) = Just s
+    fromPresenceErrorS _ = Nothing
+
 class IsErrorStanza s where
     -- | Error element of the stanza
     stanzaError :: Lens s StanzaError

source/Network/Xmpp/Types.hs

@@ -22,6 +22,7 @@ module Network.Xmpp.Types
     , IQResponse(..)
     , IQResult(..)
     , LangTag (..)
+    , langTagQ
     , langTagFromText
     , langTagToText
     , parseLangTag
@@ -38,6 +39,8 @@ module Network.Xmpp.Types
     , SaslFailure(..)
     , StreamFeatures(..)
     , Stanza(..)
+    , messageS
+    , presenceS
     , StanzaError(..)
     , StanzaErrorCondition(..)
     , StanzaErrorType(..)
@@ -45,6 +48,7 @@ module Network.Xmpp.Types
     , XmppTlsError(..)
     , StreamErrorCondition(..)
     , Version(..)
+    , versionFromText
     , StreamHandle(..)
     , Stream(..)
     , StreamState(..)
@@ -53,6 +57,7 @@ module Network.Xmpp.Types
     , ConnectionDetails(..)
     , StreamConfiguration(..)
     , xmppDefaultParams
+    , xmppDefaultParamsStrong
     , Jid(..)
 #if WITH_TEMPLATE_HASKELL
     , jidQ
@@ -704,10 +709,10 @@ data StreamFeatures = StreamFeatures
 
 -- | Signals the state of the stream connection.
 data ConnectionState
-    = Closed  -- ^ No stream has been established
+    = Closed  -- ^ Stream has not been established yet
     | Plain   -- ^ Stream established, but not secured via TLS
     | Secured -- ^ Stream established and secured via TLS
-    | Finished -- ^ Stream is closed
+    | Finished -- ^ Stream was closed
       deriving (Show, Eq, Typeable)
 
 -- | Defines operations for sending, receiving, flushing, and closing on a