Merge pull request #45 from erikd/master

Bunch of minor fixes.
jlouis · Jan 18, 2017 · a8660bc · a8660bc
2 parents e43d8c4 + 0f84649
commit a8660bc
Show file tree

Hide file tree

Showing 19 changed files with 86 additions and 57 deletions.
diff --git a/.travis.yml b/.travis.yml
@@ -0,0 +1,25 @@
+# language: haskell
+
+# See http://www.reddit.com/r/haskell/comments/1os3f6/how_to_use_travisci_with_multiple_ghc_versions/
+
+env:
+ - GHCVER=7.6.3
+ - GHCVER=7.8.4
+ - GHCVER=7.10.3
+ - GHCVER=8.0.1
+
+before_install:
+ - sudo add-apt-repository -y ppa:hvr/ghc
+ - sudo apt-get update
+ - sudo apt-get install cabal-install-1.24 ghc-$GHCVER
+ - export PATH=/opt/cabal/bin:/opt/ghc/$GHCVER/bin:$PATH
+
+install:
+ - cabal-1.24 update
+ - cabal-1.24 install --only-dependencies
+
+script:
+ - cabal-1.24 configure
+ - cabal-1.24 build
+ - cabal-1.24 haddock
+ - cabal-1.24 sdist
diff --git a/Combinatorrent.cabal b/Combinatorrent.cabal
@@ -37,10 +37,6 @@ flag threadscope
   description: Enable the eventlog necessary for ThreadScope
   default: False
 
-flag viac
-  description: Build executable over GCC compilation
-  default: False
-
 executable Combinatorrent
   hs-source-dirs: src
   main-is: Combinatorrent.hs
@@ -56,8 +52,6 @@ executable Combinatorrent
     Process.Peer.SenderQ,
     Process.Peer.Receiver
 
-  extensions: CPP
-
   build-depends:
     array >= 0.3,
     attoparsec >= 0.8,
@@ -76,7 +70,6 @@ executable Combinatorrent
     mtl,
     network,
     network-uri,
-    parsec < 4,
     pretty,
     PSQueue,
     QuickCheck >= 2.4 && < 2.9,
@@ -89,16 +82,12 @@ executable Combinatorrent
     text,
     time
 
-  ghc-options: -Wall -fno-warn-orphans -funbox-strict-fields
+  extensions: CPP
+  ghc-options: -Wall -fwarn-tabs -fno-warn-orphans -funbox-strict-fields -threaded -O2
+
   if impl(ghc >= 6.13.0)
       ghc-options: -rtsopts
 
-  if flag(viac)
-      ghc-options: -fvia-C -optc-O3
-
-  if flag(threaded)
-      ghc-options: -threaded
-
   if !flag(debug)
       cpp-options: "-DNDEBUG"
 

diff --git a/Makefile b/Makefile
@@ -11,9 +11,6 @@ test: build
 conf:
 	runghc Setup.lhs configure --user --enable-library-profiling --enable-executable-profiling --enable-optimization=2
 
-conf-viac:
-	runghc Setup.lhs configure --flags="viac" --user --enable-library-profiling --enable-executable-profiling --enable-optimization=2
-
 conf-debug:
 	runghc Setup.lhs configure --flags="debug" --user --enable-library-profiling --enable-executable-profiling --enable-optimization
 

diff --git a/README.md b/README.md
@@ -1,6 +1,8 @@
 Combinatorrent - a bittorrent client.
 =====================================
 
+[![Build Status](https://secure.travis-ci.org/jlouis/combinatorrent.svg?branch=master)](http://travis-ci.org/jlouis/combinatorrent)
+
 Introduction
 ----------
 

diff --git a/src/AdaptGhcVersion.hs b/src/AdaptGhcVersion.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE CPP #-}
+module AdaptGhcVersion
+  (
+    Monoid (..), (<$>), (<*>), pure
+  ) where
+
+import Control.Applicative ((<$>), (<*>), pure)
+import Data.Monoid (Monoid (..))
+
diff --git a/src/Digest.hs b/src/Digest.hs
@@ -7,8 +7,6 @@ module Digest
   )
 where
 
-import Control.DeepSeq
-
 import qualified Data.ByteString as B
 
 import qualified Data.ByteString.Lazy as L

diff --git a/src/Process.hs b/src/Process.hs
@@ -34,7 +34,7 @@ import Control.Monad.State.Strict
 
 import Data.Typeable
 
-import Prelude hiding (catch, log)
+import Prelude hiding (log)
 
 import System.Log.Logger
 

diff --git a/src/Process/ChokeMgr.hs b/src/Process/ChokeMgr.hs
@@ -24,7 +24,7 @@ import qualified Data.Set as S
 import Data.Traversable as T
 import GHC.Generics
 
-import Prelude hiding (catch, log)
+import Prelude hiding (log)
 
 import System.Random
 
@@ -246,7 +246,7 @@ compareInv x y =
         EQ -> EQ
         GT -> LT
 
-comparingWith :: Ord a => (a -> a -> Ordering) -> (b -> a) -> b -> b -> Ordering
+comparingWith :: (a -> a -> Ordering) -> (b -> a) -> b -> b -> Ordering
 comparingWith comp project x y =
     comp (project x) (project y)
 

diff --git a/src/Process/Console.hs b/src/Process/Console.hs
@@ -11,7 +11,7 @@ import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Monad.Reader
 
-import Prelude hiding (catch)
+import Prelude
 
 
 import Process

diff --git a/src/Process/Listen.hs b/src/Process/Listen.hs
@@ -10,7 +10,7 @@ import Control.Monad.Reader
 
 import Data.Word
 
-import Network hiding (accept, sClose)
+import Network hiding (accept)
 import Network.Socket
 import Network.BSD
 
@@ -33,10 +33,10 @@ openListen port = liftIO $ do
     proto <- getProtocolNumber "tcp"
     bracketOnError
         (socket AF_INET Stream proto)
-        (sClose)
+        (close)
         (\sock -> do
             setSocketOption sock ReuseAddr 1
-            bindSocket sock (SockAddrInet (toEnum $ fromIntegral port) iNADDR_ANY)
+            bind sock (SockAddrInet (toEnum $ fromIntegral port) iNADDR_ANY)
             listen sock maxListenQueue
             return sock
         )

diff --git a/src/Process/Peer.hs b/src/Process/Peer.hs
@@ -8,7 +8,8 @@ module Process.Peer (
     )
 where
 
-import Control.Applicative
+import AdaptGhcVersion
+
 import Control.Concurrent
 import Control.Concurrent.STM
 import Control.DeepSeq
@@ -18,7 +19,7 @@ import Control.Exception
 import Control.Monad.State
 import Control.Monad.Reader
 
-import Prelude hiding (catch, log)
+import Prelude hiding (log)
 
 import Data.Array
 import Data.Bits
@@ -27,7 +28,7 @@ import Data.Function (on)
 
 import qualified Data.PieceSet as PS
 import Data.Maybe
-import Data.Monoid(Monoid(..), Last(..))
+import Data.Monoid(Last(..))
 
 import Data.Set as S hiding (map, foldl)
 import Data.Time.Clock
@@ -790,8 +791,8 @@ allowedFast ip ihash sz n = generate n [] x []
                           bytes :: [Word32]
                           bytes    = [fromIntegral z `shiftL` s |
                                             (z, s) <- zip (B.unpack h) [24,16,8,0]]
-                          ntohl = fromIntegral . sum
+                          fntohl = fromIntegral . sum
-                      in ((ntohl bytes) `mod` fromIntegral sz) : genPieces rest
+                      in ((fntohl bytes) `mod` fromIntegral sz) : genPieces rest
     -- To prevent a Peer to reconnect, obtain a new IP and thus new FAST-set pieces, we mask out
     -- the lower bits
     ipBytes     = B.pack $ map fromIntegral

diff --git a/src/Process/Peer/Receiver.hs b/src/Process/Peer/Receiver.hs
@@ -10,7 +10,7 @@ import Control.Monad.Reader
 import Control.Monad.State
 
 import qualified Data.ByteString as B
-import Prelude hiding (catch, log)
+import Prelude hiding (log)
 
 import Data.Serialize.Get
 

diff --git a/src/Process/Peer/Sender.hs b/src/Process/Peer/Sender.hs
@@ -27,7 +27,7 @@ start :: Socket -> TMVar L.ByteString -> SupervisorChannel -> IO ThreadId
 start s ch supC = spawnP (CF ch s) () ({-# SCC "Sender" #-}
                                           (cleanupP pgm
                                             (defaultStopHandler supC)
-                                            (liftIO $ sClose s)))
+                                            (liftIO $ close s)))
 pgm :: Process CF () ()
 pgm = do
    ch <- asks chan

diff --git a/src/Process/Peer/SenderQ.hs b/src/Process/Peer/SenderQ.hs
@@ -10,7 +10,7 @@ import Control.Concurrent.STM
 import Control.Monad.Reader
 import Control.Monad.State
 
-import Prelude hiding (catch, log)
+import Prelude hiding (log)
 
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L

diff --git a/src/Process/PeerMgr.hs b/src/Process/PeerMgr.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP, TupleSections #-}
 module Process.PeerMgr (
    -- * Types
      Peer(..)
@@ -10,7 +10,9 @@ module Process.PeerMgr (
 )
 where
 
-import Control.Applicative
+#if __GLASGOW_HASKELL__ <= 708
+import AdaptGhcVersion
+#endif
 
 import Control.Concurrent
 import Control.Concurrent.STM
@@ -112,7 +114,7 @@ incomingPeers msg =
                        _ <- addIncoming conn
                        return ()
                else do debugP "Already too many peers, closing!"
-                       liftIO $ Sock.sClose s
+                       liftIO $ Sock.close s
        NewTorrent ih tl -> do
            modify (\s -> s { cmMap = M.insert ih tl (cmMap s)})
        StopTorrent _ih -> do

diff --git a/src/Process/Tracker.hs b/src/Process/Tracker.hs
@@ -8,13 +8,16 @@
 -- about the torrent in question. It may also respond with an error in which
 -- case we should present it to the user.
 --
+{-# LANGUAGE CPP #-}
 module Process.Tracker
     ( start
     )
 where
 
-import Prelude hiding (catch)  
+#if __GLASGOW_HASKELL__ <= 708
-import Control.Applicative
+import AdaptGhcVersion
+#endif
+
 import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Monad.Reader
@@ -206,7 +209,7 @@ decodeIps4 bs | B.null bs = []
                     let (ip, r1) = B.splitAt 4 bs
                         (port, r2) = B.splitAt 2 r1
                         i' = cW32 ip
-                        p' = PortNum $ cW16 port
+                        p' = fromIntegral $ cW16 port
                     in PeerMgr.Peer (S.SockAddrInet p' i') : decodeIps4 r2
               | otherwise = [] -- Some trackers fail spectacularly
 
@@ -216,7 +219,7 @@ decodeIps6 bs | B.null bs = []
                     let (ip6, r1) = B.splitAt 16 bs
                         (port, r2) = B.splitAt 2 r1
                         i' = cW128 ip6
-                        p' = PortNum $ cW16 port
+                        p' = fromIntegral $ cW16 port
                     in PeerMgr.Peer (S.SockAddrInet6 p' 0 i' 0) : decodeIps6 r2
               | otherwise = [] -- Some trackers fail spectacularly
 
@@ -241,12 +244,12 @@ cW128 bs =
 bubbleUpURL :: AnnounceURL -> [AnnounceURL] -> Process CF ST ()
 bubbleUpURL _ (_:[]) = return ()
 bubbleUpURL _ [] = return ()
-bubbleUpURL url tier@(x:_) = if url == x 
+bubbleUpURL url tier@(x:_) = if url == x
                               then return ()
                               else do
                                 alist <- gets announceList
-                                let newTier = url : filter (/=url) tier 
+                                let newTier = url : filter (/=url) tier
-                                    newAnnounceList = map (\a -> if a /= tier then a else newTier) alist 
+                                    newAnnounceList = map (\a -> if a /= tier then a else newTier) alist
                                 _ <- modify (\s -> s { announceList = newAnnounceList })
                                 return ()
 
@@ -258,9 +261,9 @@ tryThisTier' s (x:xs) = do url <- buildRequestURL s x
                              Just u  -> return u
                            resp <- trackerRequest uri
                            case resp of
-                             Left m  -> if null xs 
+                             Left m  -> if null xs
                                         then return $ Left m
-                                        else tryThisTier' s xs 
+                                        else tryThisTier' s xs
                              Right r -> return $ Right (x, r)
 
 
@@ -277,22 +280,22 @@ tryThisTier params tier = do resp <- tryThisTier' params tier
 
 queryTrackers' :: Status.StatusState -> [[AnnounceURL]] -> Process CF ST (Either String TrackerResponse)
 queryTrackers' _ []     = return $ Left "Empty announce-list"
-queryTrackers' p (x:[]) = tryThisTier p x --last element, so return whatever it gives us 
+queryTrackers' p (x:[]) = tryThisTier p x --last element, so return whatever it gives us
 queryTrackers' p (x:xs) = do resp <- tryThisTier p x
-                             case resp of 
+                             case resp of
-                               Left  _ -> queryTrackers' p xs -- in case of error, move to the next tier 
+                               Left  _ -> queryTrackers' p xs -- in case of error, move to the next tier
                                Right _ -> return $ resp       -- if success just return result
 
 queryTrackers :: Status.StatusState ->  Process CF ST (Either String TrackerResponse)
-queryTrackers ss = do alist <- gets announceList                      
+queryTrackers ss = do alist <- gets announceList
                       queryTrackers' ss alist
 
-            
+
 
 -- TODO: Do not recurse infinitely here.
 trackerRequest :: URI -> Process CF ST (Either String TrackerResponse)
 trackerRequest uri =
-    do debugP $ "Querying URI: " ++ (show uri) 
+    do debugP $ "Querying URI: " ++ (show uri)
        resp <- liftIO $ catch (simpleHTTP request) (\e -> let err = show (e :: IOException)
                                                           in return . Left . ErrorMisc $ err)
        case resp of
@@ -341,7 +344,7 @@ urlEncode (h:t) = let str = if reserved (ord h) then escape h else [h]
           | x >= ord 'A' && x <= ord 'Z' = False
           | x >= ord '0' && x <= ord '9' = False
           | x <= 0x20 || x >= 0x7F = True
-          | otherwise = x `elem` map ord 
+          | otherwise = x `elem` map ord
                [';','/','?',':','@','&'
                 ,'=','+',',','$','{','}'
                 ,'|','\\','^','[',']','`'

diff --git a/src/Protocol/Wire.hs b/src/Protocol/Wire.hs
@@ -28,7 +28,7 @@ import Control.Monad
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
 
-import Data.Attoparsec as A
+import Data.Attoparsec.ByteString as A
 import Data.Bits (testBit, setBit)
 
 import Data.Serialize

diff --git a/src/Supervisor.hs b/src/Supervisor.hs
@@ -23,7 +23,7 @@ import Control.Concurrent.STM
 import Control.Monad.State
 import Control.Monad.Reader
 
-import Prelude hiding (catch)
+import Prelude
 
 import Process