~singpolyma/jingle-xmpp

b9ace4a2a7890fc93df2e958bec91f4ff69185d7 — Stephen Paul Weber 3 years ago 956170d
Current version in use by cheogram
3 files changed, 50 insertions(+), 15 deletions(-)

M Jingle.hs
M Jingle/Socks5Server.hs
M StoreChunks.hs
M Jingle.hs => Jingle.hs +31 -6
@@ 2,7 2,9 @@ module Jingle (
	setupJingleHandlers,
	jingleHandler,
	ibbHandler,
	tsidToSidMap
	tsidToSidMap,
	JingleSID,
	JingleTSID
) where

import Prelude ()


@@ 196,6 198,9 @@ jingleHandler' hostPort newSession newTransport iq@XMPP.IQ {
	| jingleAction (s"transport-info") iq,
	  (_:_) <- jingleTransport `overChildrenOf` content =
		XMPP.putStanza $ iqReply Nothing iq
	| jingleAction (s"session-info") iq,
	  (_:_) <- XML.isNamed (s"{urn:xmpp:jingle:apps:file-transfer:5}checksum") =<< children =
		XMPP.putStanza $ iqReply Nothing iq
	| jingleAction (s"transport-replace") iq,
	  [tsid] <- elementAttributeText
	            (s"sid")


@@ 307,19 312,39 @@ tsidToSidMap notifyBySid =
				Just sid -> notifyBySid sid path
	)

sidToIqMap :: (Unexceptional m) =>
	   (XMPP.IQ -> FilePath -> UIO ())
	-> m (
		JingleSID -> XMPP.IQ -> UIO (),
		JingleSID -> FilePath -> UIO ()
	)
sidToIqMap notifyByIq =
	fromIO_ (Cache.newCache (Just $ TimeSpec 900 0)) >>= \cache ->
	return (
		\(JingleSID sid) iq -> do
			fromIO_ $ Cache.purgeExpired cache
			fromIO_ $ Cache.insert cache sid iq
		,
		\(JingleSID sid) path -> do
			miq <- fromIO_ $ Cache.lookup' cache sid
			case miq of
				Nothing -> return ()
				Just iq -> notifyByIq iq path
	)

-- | Probably you want this
setupJingleHandlers :: (Unexceptional m) =>
	   FilePath
	-> [Socket.SockAddr]
	-> (Text, Socket.PortNumber)
	-> (JingleSID -> XMPP.IQ -> UIO ())
	-> (JingleSID -> FilePath -> UIO ())
	-> (String -> UIO ())
	-> (XMPP.IQ -> FilePath -> UIO ())
	-> m (Either IOError (XMPP.IQ -> XMPP.XMPP ()))
setupJingleHandlers storePath ports hostPort newSession transferDone = do
setupJingleHandlers storePath ports hostPort logger transferDoneIq = do
	(newSession, transferDone) <- sidToIqMap transferDoneIq
	(newTransport, transportDone) <- tsidToSidMap transferDone
	(fmap.fmap) (\() ->
			iqSetHandler storePath hostPort
				newSession newTransport transportDone
		) $
		Socks5Server.start storePath ports
			(fromIO_ . print) transportDone
		Socks5Server.start storePath ports logger transportDone

M Jingle/Socks5Server.hs => Jingle/Socks5Server.hs +14 -5
@@ 18,13 18,14 @@ import Util
start :: (Unexceptional m) =>
	   FilePath
	-> [Socket.SockAddr]
	-> (IOError -> UIO ())
	-> (String -> UIO ())
	-> (JingleTSID -> FilePath -> UIO ())
	-> m (Either IOError ())
start storePath ports logger transferFinished = UIO.fromIO' (error.show) $
	forM_ ports $ \port -> do
		Just family <- return $ addrToFamily port
		socket <- Socket.socket family Socket.Stream 0
		Socket.setSocketOption socket Socket.ReuseAddr 1
		Socket.bind socket port
		Socket.listen socket 5
		void $ UIO.fork (threadLoop port socket)


@@ 33,22 34,30 @@ start storePath ports logger transferFinished = UIO.fromIO' (error.show) $
	addrToFamily Socket.SockAddrInet6 {} = Just Socket.AF_INET6
	addrToFamily _ = Nothing

	exceptionLogger :: IOError -> UIO ()
	exceptionLogger = logger . show

	threadLoop port socket =
		afterAccept port socket =<<
		UIO.fromIO' (error.show) (Socket.accept socket)

	afterAccept port socket (Right (conn, _)) = do
		void $ UIO.fork $ (either logger return =<<) $
			UIO.fromIO' (error.show) $ processConnection conn
		void $ UIO.forkFinally
			(UIO.fromIO' (error.show) $ processConnection conn)
			afterAfterAccept
		threadLoop port socket
	afterAccept port socket (Left e) = do
		logger e
		exceptionLogger e
		UIO.unsafeFromIO $ Socket.close socket
		-- Should these just get logged, or should the process die if we
		-- cannot restart?
		either logger return =<<
		either exceptionLogger return =<<
			start storePath [port] logger transferFinished

	afterAfterAccept (Right (Right ())) = return ()
	afterAfterAccept (Right (Left e)) = exceptionLogger e
	afterAfterAccept (Left e) = logger $ show e

	processConnection conn = do
		request <- socksListen conn
		let SocksAddrDomainName addr = requestDstAddr request

M StoreChunks.hs => StoreChunks.hs +5 -4
@@ 5,7 5,7 @@ import BasicPrelude
import Crypto.Hash
	(Digest, SHA1, SHA256, SHA512, hashUpdate, hashFinalize, hashInit)
import System.Directory
	(createDirectoryIfMissing, renameFile, createFileLink, doesPathExist)
	(createDirectoryIfMissing, renameFile, createFileLink, doesFileExist)
import UnexceptionalIO (Unexceptional, UIO)
import qualified UnexceptionalIO as UIO
import qualified Data.ByteString as ByteString


@@ 17,7 17,7 @@ digestCID = CID.cidToText . CID.newCidV1 CID.Raw

createLinkIfNotExist :: FilePath -> FilePath -> IO ()
createLinkIfNotExist target link = do
	exist <- doesPathExist link
	exist <- doesFileExist link
	when (not exist) $ createFileLink target link

storeChunks :: (Unexceptional m) =>


@@ 57,8 57,9 @@ storeChunks storePath tmpName getChunk = loop hashInit hashInit hashInit
		let sha256f = hashFinalize sha256
		let sha512f = hashFinalize sha512
		let finalPath = cidPath sha512f
		let finalCID = textToString (digestCID sha512f)
		(fmap.fmap) (const (finalPath, sha1f, sha256f, sha512f)) $
			UIO.fromIO' (error.show) $ do
				renameFile tmpPath finalPath
				createLinkIfNotExist finalPath (cidPath sha1f)
				createLinkIfNotExist finalPath (cidPath sha256f)
				createLinkIfNotExist finalCID (cidPath sha1f)
				createLinkIfNotExist finalCID (cidPath sha256f)