From 62d31ca46fb3143af3004730195ff6554cf3fa40 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sun, 5 Jan 2020 20:03:18 -0500 Subject: Forward port to GHC 8.10.1-alpha2 (83edba07e4) --- dht/Data/BitSyntax.hs | 7 ++++++- dht/dht-client.cabal | 21 ++++++++++++++------ dht/examples/dht.hs | 5 +++++ dht/src/Codec/AsciiKey256.hs | 7 ++++--- dht/src/Data/Tox/Onion.hs | 6 +++++- dht/src/Network/BitTorrent/MainlineDHT.hs | 6 +++++- dht/src/Network/Tox/Avahi.hs | 22 +++++++++++++++++++-- dht/src/Network/Tox/NodeId.hs | 27 ++++++++++++++----------- network-addr/src/Network/Address.hs | 6 +++++- server/server.cabal | 33 ++++++++++++++++++++++++++++++- 10 files changed, 113 insertions(+), 27 deletions(-) diff --git a/dht/Data/BitSyntax.hs b/dht/Data/BitSyntax.hs index 6d14d0c1..9ebffe73 100644 --- a/dht/Data/BitSyntax.hs +++ b/dht/Data/BitSyntax.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TemplateHaskell #-} -- | This module contains fuctions and templates for building up and breaking -- down packed bit structures. It's something like Erlang's bit-syntax (or, -- actually, more like Python's struct module). @@ -278,7 +279,11 @@ readElement (stmts, inputname, tuplenames) (Context funcname) = do let stmt = BindS (TupP [VarP valname, VarP restname]) (AppE (AppE (VarE funcname) (VarE inputname)) +#if MIN_VERSION_template_haskell(2,16,0) + (TupE $ map (Just . VarE) $ reverse tuplenames)) +#else (TupE $ map VarE $ reverse tuplenames)) +#endif return (stmt : stmts, restname, valname : tuplenames) diff --git a/dht/dht-client.cabal b/dht/dht-client.cabal index 0da181df..6a449a6a 100644 --- a/dht/dht-client.cabal +++ b/dht/dht-client.cabal @@ -27,6 +27,10 @@ description: extra-source-files: ChangeLog cbits/*.h +flag avahi + description: Advertise Tox node on avahi. + Disable to avoid an indirect dependency on lens. + default: True flag network-uri description: Use network-uri package. @@ -207,7 +211,6 @@ library , blaze-builder , exceptions , hinotify - , avahi >= 0.2.0 , dput-hslogger , word64-map , network-addr @@ -223,6 +226,9 @@ library if impl(ghc < 8) Build-depends: transformers + if flag(avahi) + Build-depends: avahi >= 0.2.0 + if flag(no-constraint-extras) build-depends: dependent-sum < 0.6 else @@ -282,11 +288,14 @@ library build-depends: cryptonite >= 0.22 executable avahi - hs-source-dirs: examples - main-is: avahi.hs - default-language: Haskell2010 - build-depends: base-prelude, dht-client, avahi, network - ghc-options: -fobject-code + hs-source-dirs: examples + main-is: avahi.hs + if flag(avahi) + default-language: Haskell2010 + build-depends: base-prelude, dht-client, avahi, network + ghc-options: -fobject-code + else + buildable: False executable dht hs-source-dirs: examples diff --git a/dht/examples/dht.hs b/dht/examples/dht.hs index 3e1b1656..6615477b 100644 --- a/dht/examples/dht.hs +++ b/dht/examples/dht.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE NondecreasingIndentation #-} import Control.Applicative import Control.Monad @@ -13,6 +14,10 @@ import System.IO import System.IO.Unsafe import qualified Data.ByteString as B +#if MIN_VERSION_haskeline(0,8,0) +import Control.Exception (handle) +#endif + -- | Reads one character. If it is not a digit, -- then it is discarded and 'Nothing' is returned. hReadDigit :: Handle -> IO (Maybe Char) diff --git a/dht/src/Codec/AsciiKey256.hs b/dht/src/Codec/AsciiKey256.hs index ee17b7c1..1738a368 100644 --- a/dht/src/Codec/AsciiKey256.hs +++ b/dht/src/Codec/AsciiKey256.hs @@ -3,6 +3,7 @@ module Codec.AsciiKey256 where import Control.Applicative import Control.Monad +import Control.Monad.Fail as MF import Data.Bits import qualified Data.ByteArray as BA ;import Data.ByteArray as BA (ByteArrayAccess) @@ -112,7 +113,7 @@ readsPrecKey256 publicKey str | otherwise = [] -parseKey256 :: (Monad m, Alternative m) => String -> m ByteString +parseKey256 :: (MonadFail m, Alternative m) => String -> m ByteString parseKey256 nidstr = do let nidbs = C8.pack nidstr (bs,_) = Base16.decode nidbs @@ -121,7 +122,7 @@ parseKey256 nidstr = do 43 -> parseToken32 nidstr _ -> Left "Wrong size of key." idbs <- (guard (B.length bs == 32) >> return bs) - <|> either fail return enid + <|> either MF.fail return enid return idbs readP_key256 :: RP.ReadP ByteString @@ -131,7 +132,7 @@ readP_key256 = do , fmap (32,) (sequence $ replicate 52 (RP.satisfy zb32digit)) , fmap (64,) (sequence $ replicate 43 (RP.satisfy b64digit)) ] - let failure = fail "Bad key." + let failure = MF.fail "Bad key." case is64 of 32 -> case parse32Token32 hexhash of Right bs -> return bs diff --git a/dht/src/Data/Tox/Onion.hs b/dht/src/Data/Tox/Onion.hs index 55e81069..d6f747d9 100644 --- a/dht/src/Data/Tox/Onion.hs +++ b/dht/src/Data/Tox/Onion.hs @@ -38,7 +38,11 @@ import Data.Function import Data.Functor.Contravariant import Data.Functor.Identity #if MIN_VERSION_iproute(1,7,4) -import Data.IP hiding (fromSockAddr) +import Data.IP hiding ( fromSockAddr +#if MIN_VERSION_iproute(1,7,8) + , toSockAddr +#endif + ) #else import Data.IP #endif diff --git a/dht/src/Network/BitTorrent/MainlineDHT.hs b/dht/src/Network/BitTorrent/MainlineDHT.hs index e604f5e5..fc69fedd 100644 --- a/dht/src/Network/BitTorrent/MainlineDHT.hs +++ b/dht/src/Network/BitTorrent/MainlineDHT.hs @@ -40,7 +40,11 @@ import Data.Digest.CRC32C import Data.Function (fix) import Data.Hashable #if MIN_VERSION_iproute(1,7,4) -import Data.IP hiding (fromSockAddr) +import Data.IP hiding ( fromSockAddr +#if MIN_VERSION_iproute(1,7,8) + , toSockAddr +#endif + ) #else import Data.IP #endif diff --git a/dht/src/Network/Tox/Avahi.hs b/dht/src/Network/Tox/Avahi.hs index 635ba656..2ca6515c 100644 --- a/dht/src/Network/Tox/Avahi.hs +++ b/dht/src/Network/Tox/Avahi.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} module Network.Tox.Avahi @@ -10,11 +11,17 @@ module Network.Tox.Avahi import Control.Applicative import Data.Foldable import Network.Address -import Network.Avahi import Network.BSD (getHostName) import Network.Tox.NodeId import Text.Read +#if defined(VERSION_avahi) +import Network.Avahi +#else +data Service = Service +#endif + + toxServiceName :: String toxServiceName = "_tox_dht._udp" @@ -26,7 +33,9 @@ a <.> b = a ++ "." ++ b toxService :: String -> PortNumber -> NodeId -> (Maybe NodeId) -> Service toxService hostname (fromIntegral -> port) dhtkey toxid = - Service { + Service +#if defined(VERSION_avahi) + { serviceProtocol = PROTO_UNSPEC, serviceName = "Tox DHT @ " ++ hostname, serviceType = toxServiceName, @@ -36,10 +45,15 @@ toxService hostname (fromIntegral -> port) dhtkey toxid = servicePort = port, serviceText = maybe (show dhtkey) (show . ((,) dhtkey)) toxid } +#endif announceToxServiceWithHostname :: String -> PortNumber -> NodeId -> (Maybe NodeId) -> IO () +#if defined(VERSION_avahi) announceToxServiceWithHostname = (boobs.boobs) announce toxService where boobs = ((.).(.)) +#else +announceToxServiceWithHostname _ _ _ _ = return () +#endif announceToxService :: PortNumber -> NodeId -> (Maybe NodeId) -> IO () announceToxService a b c = do @@ -48,6 +62,7 @@ announceToxService a b c = do queryToxService :: (NodeInfo -> Maybe NodeId -> IO ()) -> IO () queryToxService cb = +#if defined(VERSION_avahi) browse $ BrowseQuery { lookupProtocol = PROTO_UNSPEC @@ -63,3 +78,6 @@ queryToxService cb = addr = readMaybe =<< serviceAddress p = fromIntegral servicePort forM_ nid $ \n -> forM_ addr $ \a -> cb (NodeInfo n a p) (snd <$> both) +#else + return () +#endif diff --git a/dht/src/Network/Tox/NodeId.hs b/dht/src/Network/Tox/NodeId.hs index d05e3697..667e7d71 100644 --- a/dht/src/Network/Tox/NodeId.hs +++ b/dht/src/Network/Tox/NodeId.hs @@ -47,6 +47,7 @@ module Network.Tox.NodeId import Control.Applicative import Control.Arrow import Control.Monad +import Control.Monad.Fail as MF #ifdef CRYPTONITE_BACKPORT import Crypto.Error.Types (CryptoFailable (..), throwCryptoError) @@ -70,7 +71,11 @@ import Data.Char import Data.Data import Data.Hashable #if MIN_VERSION_iproute(1,7,4) -import Data.IP hiding (fromSockAddr) +import Data.IP hiding ( fromSockAddr +#if MIN_VERSION_iproute(1,7,8) + , toSockAddr +#endif + ) #else import Data.IP #endif @@ -258,7 +263,7 @@ getIP 0x02 = IPv4 <$> S.get getIP 0x0a = IPv6 <$> S.get getIP 0x82 = IPv4 <$> S.get -- TODO: TCP TOX_TCP_INET getIP 0x8a = IPv6 <$> S.get -- TODO: TCP TOX_TCP_INET6 -getIP x = fail ("unsupported address family ("++show x++")") +getIP x = MF.fail ("unsupported address family ("++show x++")") instance Sized NodeInfo where size = VarSize $ \(NodeInfo nid ip port) -> @@ -306,7 +311,7 @@ instance Read NodeInfo where return (nid,addrstr) (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) ) (ip,port) <- case RP.readP_to_S (ip_w_port i) addrstr of - [] -> fail "Bad address." + [] -> MF.fail "Bad address." ((ip,port),_):_ -> return (ip,port) return $ NodeInfo nid ip port @@ -406,7 +411,7 @@ getIP 0x02 = IPv4 <$> S.get getIP 0x0a = IPv6 <$> S.get getIP 0x82 = IPv4 <$> S.get -- TODO: TCP getIP 0x8a = IPv6 <$> S.get -- TODO: TCP -getIP x = fail ("unsupported address family ("++show x++")") +getIP x = MF.fail ("unsupported address family ("++show x++")") instance S.Serialize NodeInfo where get = do @@ -445,7 +450,7 @@ instance Read NodeInfo where addrstr <- parseAddr nid <- case Base16.decode $ C8.pack hexhash of (bs,_) | B.length bs==32 -> return (PubKey bs) - _ -> fail "Bad node id." + _ -> MF.fail "Bad node id." return (nid,addrstr) (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) ) let raddr = do @@ -457,7 +462,7 @@ instance Read NodeInfo where return (ip, port) (ip,port) <- case RP.readP_to_S raddr addrstr of - [] -> fail "Bad address." + [] -> MF.fail "Bad address." ((ip,port),_):_ -> return (ip,port) return $ NodeInfo nid ip port @@ -518,15 +523,15 @@ instance Read NoSpam where ('0':'x':ws,rs) | (length ws == 12) -> base16decode rs (NoSpam <$> get <*> (Just <$> get)) ws _ -> [] -base64decode :: Monad m => t1 -> Get t -> String -> m (t, t1) +base64decode :: MonadFail m => t1 -> Get t -> String -> m (t, t1) base64decode rs getter s = - either fail (\a -> return (a,rs)) + either MF.fail (\a -> return (a,rs)) $ runGet getter =<< Base64.decode (C8.pack $ map (nmtoken64 False) s) -base16decode :: Monad m => t1 -> Get t -> String -> m (t, t1) +base16decode :: MonadFail m => t1 -> Get t -> String -> m (t, t1) base16decode rs getter s = - either fail (\a -> return (a,rs)) + either MF.fail (\a -> return (a,rs)) $ runGet getter $ fst $ Base16.decode (C8.pack s) @@ -559,7 +564,7 @@ instance Show NoSpamId where show (NoSpamId nspam pub) = '$' : nospam64 nspam ++ "@" ++ show (key2id pub) ++ ".tox" instance Read NoSpamId where - readsPrec d s = either fail id $ do + readsPrec d s = either MF.fail id $ do (jid,xs) <- Right $ break isSpace s nsid <- parseNoSpamId $ Text.pack jid return [(nsid,xs)] diff --git a/network-addr/src/Network/Address.hs b/network-addr/src/Network/Address.hs index 57bb11d1..d1275b53 100644 --- a/network-addr/src/Network/Address.hs +++ b/network-addr/src/Network/Address.hs @@ -111,7 +111,11 @@ import Data.Char import Data.Convertible import Data.Default #if MIN_VERSION_iproute(1,7,4) -import Data.IP hiding (fromSockAddr) +import Data.IP hiding ( fromSockAddr +#if MIN_VERSION_iproute(1,7,8) + , toSockAddr +#endif + ) #else import Data.IP #endif diff --git a/server/server.cabal b/server/server.cabal index 95d7aacf..44441ef1 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -15,11 +15,42 @@ maintainer: joe@jerkface.net category: Network extra-source-files: CHANGELOG.md +flag network-uri + description: Use network-uri package. + default: True + +-- supports network-2.7, 2.8, with deprecation warnings +flag old-network-bsd + description: Use network-bsd package. + default: True + +-- supports network >3.0 +flag new-network-bsd + description: Use newer network-bsd package. + default: False + + library exposed-modules: Network.QueryResponse, Network.StreamServer, Network.SocketLike, Network.QueryResponse.TCP, Data.TableMethods, Connection.Tcp, Control.Concurrent.Delay, DNSCache, GetHostByAddr, ControlMaybe, SockAddr, Control.Concurrent.PingMachine, Connection other-modules: ForkLabeled, DebugTag other-extensions: CPP, GADTs, LambdaCase, PartialTypeSignatures, RankNTypes, ScopedTypeVariables, TupleSections, TypeFamilies, TypeOperators, OverloadedStrings, GeneralizedNewtypeDeriving, DoAndIfThenElse, FlexibleInstances, StandaloneDeriving - build-depends: base, stm, bytestring, dependent-map, dependent-sum, contravariant, containers, time, network, cpu, dput-hslogger, directory, lifted-base, hashable, conduit, text, psq-wrap, minmax-psq, lifted-concurrent, word64-map, network-addr + build-depends: base, stm, bytestring, dependent-map, dependent-sum, contravariant, containers, time, cpu, dput-hslogger, directory, lifted-base, hashable, conduit, text, psq-wrap, minmax-psq, lifted-concurrent, word64-map, network-addr hs-source-dirs: src default-language: Haskell2010 cpp-options: -DTHREAD_DEBUG + if flag(old-network-bsd) + Build-depends: network < 3.0 + , network-uri >= 2.6 + , network-bsd < 2.8.1.0 + else + if flag(new-network-bsd) + Build-depends: network >= 3.0 + , network-uri >= 2.6 + , network-bsd >= 2.8.1.0 + else + if flag(network-uri) + Build-depends: network >= 2.6 && < 3.0 + , network-uri >= 2.6 + else + Build-depends: network >= 2.4 && < 2.6 + -- cgit v1.2.3