xml-push 0.0.0.11 → 0.0.0.12
raw patch · 4 files changed
+25/−18 lines, 4 filesdep +x509-validationPVP ok
version bump matches the API change (PVP)
Dependencies added: x509-validation
API changes (from Hackage documentation)
Files
- src/Network/XmlPush/Xmpp/Server.hs +1/−1
- src/Network/XmlPush/Xmpp/Server/Common.hs +11/−11
- src/Network/XmlPush/Xmpp/Tls/Server.hs +9/−3
- xml-push.cabal +4/−3
src/Network/XmlPush/Xmpp/Server.hs view
@@ -55,7 +55,7 @@ let r = fromHandleLike h =$= input ns =$= debug- =$= setIds h ynr rids+ =$= setIds h ynr (user st) rids =$= convert fromMessage =$= filter isJust =$= convert fromJust
src/Network/XmlPush/Xmpp/Server/Common.hs view
@@ -22,10 +22,10 @@ import System.Random import Text.XML.Pipe import Network.XMPiPe.Core.C2S.Server-import Network.XMPiPe.Core.C2S.Client (toJid) import Network.Sasl import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC import qualified Network.Sasl.DigestMd5.Server as DM5 import qualified Network.Sasl.ScramSha1.Server as SS1 @@ -98,15 +98,16 @@ putSaslState _ _ = error "XSt.getSaslState: null random list" setIds :: (HandleLike h, MonadBase IO (HandleMonad h)) => h ->- (XmlNode -> Bool) -> TChan BS.ByteString -> Pipe Mpi Mpi (HandleMonad h) ()-setIds h ynr rids = (await >>=) . maybe (return ()) $ \mpi -> do+ (XmlNode -> Bool) -> Jid -> TChan BS.ByteString ->+ Pipe Mpi Mpi (HandleMonad h) ()+setIds h ynr you rids = (await >>=) . maybe (return ()) $ \mpi -> do yield mpi if boolXmlNode ynr mpi then when (isGetSet mpi) . lift . liftBase . atomically $ writeTChan rids (fromJust $ getId mpi)- else lift $ returnEmpty h "hoge"- lift . liftBase . putStrLn $ "\nsetIds: " ++ show (getId mpi)- setIds h ynr rids+ else lift $ returnEmpty h (fromJust $ getId mpi) you+ lift . hlDebug h "medium" . BSC.pack $ "\nsetIds: " ++ show (getId mpi)+ setIds h ynr you rids isGetSet :: Mpi -> Bool isGetSet (Iq Tags { tagType = Just "set" } _) = True@@ -120,12 +121,12 @@ boolXmlNode :: (XmlNode -> Bool) -> Mpi -> Bool boolXmlNode f (Iq _ [n]) = f n-boolXmlNode _ _ = False+boolXmlNode _ _ = True -returnEmpty :: (HandleLike h, MonadBase IO (HandleMonad h)) => h -> BS.ByteString -> HandleMonad h ()-returnEmpty h i = runPipe_ $ yield e =$= output =$= debug =$= toHandleLike h+returnEmpty :: (HandleLike h, MonadBase IO (HandleMonad h)) => h ->+ BS.ByteString -> Jid -> HandleMonad h ()+returnEmpty h i you = runPipe_ $ yield e =$= output =$= debug =$= toHandleLike h where- you = toJid "hoge@hogehost" e = Iq (tagsType "result") { tagId = Just i, tagTo = Just you } [] makeMpi :: MonadBase IO m => Jid ->@@ -145,7 +146,6 @@ tagTo = Just usr } [n] else do i <- lift . liftBase .atomically $ readTChan rids- lift . liftBase . putStrLn $ "makeMpi: " ++ show i yield $ Iq (tagsType "return") { tagId = Just i, tagTo = Just usr
src/Network/XmlPush/Xmpp/Tls/Server.hs view
@@ -15,6 +15,7 @@ import Control.Monad.Trans.Control import Control.Concurrent.STM import Data.Maybe+import Data.List (intercalate) import Data.HandleLike import Data.Pipe import Data.Pipe.Flow@@ -22,15 +23,18 @@ import Data.Pipe.TChan import Data.UUID import Data.X509+import Data.X509.Validation import System.Random import Text.XML.Pipe import Network.XMPiPe.Core.C2S.Server import Network.XmlPush import Network.Sasl import Network.PeyoTLS.TChan.Server+import Numeric import "crypto-random" Crypto.Random -- import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString as BS import Network.XmlPush.Xmpp.Common import Network.XmlPush.Xmpp.Server.Common@@ -67,11 +71,10 @@ (Just ns, st) <- (`runStateT` initXSt dn) . runPipe $ do fromTChan inp =$= sasl dn (retrieves dn ps) =$= toTChan otp fromTChan inp =$= bind dn [] =@= toTChan otp- liftBase . print $ user st let r = fromTChan inp =$= input ns =$= debug- =$= setIds h ynr rids+ =$= setIds h ynr (user st) rids =$= convert fromMessage =$= filter isJust =$= convert fromJust@@ -97,7 +100,10 @@ Pipe XmlNode XmlNode m () checkCert c cc = (await >>=) . maybe (return ()) $ \n -> do case cc n of- Just ck -> unless (ck c) $ error "checkCert: bad certificate"+ Just ck -> unless (ck c) . error $ "checkCert: bad certificate "+ ++ intercalate ":" (map (flip showHex "")+ (BS.unpack . (\(Fingerprint bs) -> bs) $+ getFingerprint c HashSHA256)) _ -> return () yield n checkCert c cc
xml-push.cabal view
@@ -2,7 +2,7 @@ cabal-version: >= 1.8 name: xml-push-version: 0.0.0.11+version: 0.0.0.12 stability: Experimenmtal author: Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer: Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -100,7 +100,7 @@ source-repository this type: git location: git://github.com/YoshikuniJujo/xml-push.git- tag: xml-push-0.0.0.11+ tag: xml-push-0.0.0.12 library hs-source-dirs: src@@ -124,6 +124,7 @@ handle-like == 0.1.*, monad-control == 0.3.*, transformers-base == 0.4.*, monads-tf == 0.1.*, bytestring == 0.10.*, xmpipe == 0.0.*, sasl == 0.0.*, random == 1.0.*, uuid == 1.3.*, stm == 2.4.*, crypto-random == 0.0.*,- x509 == 1.4.*, x509-store == 1.4.*, tighttp == 0.0.*+ x509 == 1.4.*, x509-store == 1.4.*, x509-validation == 1.5.*,+ tighttp == 0.0.* ghc-options: -Wall extensions: DoAndIfThenElse