cryptopals

Matasano's cryptopals challenges (cryptopals.com).
git clone git://git.jtobin.io/cryptopals.git
Log | Files | Refs | README | LICENSE

Network.hs (2378B)

      1 module Pipes.Network (
      2     N.Socket(..)
      3   , N.SockAddr(..)
      4   , NT.HostPreference(..)
      5   , N.ServiceName
      6   , Protocol
      7 
      8   , fromSocket
      9   , toSocket
     10   , session
     11   , dance
     12 
     13   , NT.connect
     14   , NT.serve
     15   , NT.send
     16   , NT.recv
     17   , NT.closeSock
     18   ) where
     19 
     20 import Control.Monad.IO.Class
     21 import qualified Data.Binary as DB
     22 import qualified Data.ByteString as BS
     23 import Pipes
     24 import qualified Pipes.Binary as PB
     25 import qualified Pipes.Parse as PP
     26 import qualified Pipes.Prelude as P
     27 import qualified Network.Simple.TCP as NT
     28 import qualified Network.Socket as N
     29 import qualified Network.Socket.ByteString as NB
     30 import GHC.Word (Word32)
     31 
     32 type Protocol m b c = b -> m c
     33 
     34 -- receive on socket
     35 fromSocket
     36   :: MonadIO m
     37   => N.Socket
     38   -> Word32
     39   -> Producer' BS.ByteString m ()
     40 fromSocket s n = loop where
     41   loop = do
     42     b <- liftIO (NB.recv s (fromIntegral n))
     43     if   BS.null b
     44     then pure ()
     45     else do
     46       yield b
     47       loop
     48 
     49 -- send on socket
     50 toSocket
     51   :: MonadIO m
     52   => N.Socket
     53   -> Consumer' BS.ByteString m r
     54 toSocket s = for cat (NT.send s)
     55 
     56 -- receive on alternate sockets
     57 rhumba
     58   :: MonadIO m
     59   => N.Socket
     60   -> N.Socket
     61   -> Word32
     62   -> Producer' BS.ByteString m ()
     63 rhumba a b n = loop True where
     64   loop lip = do
     65     let s = if lip then a else b
     66     b <- liftIO (NB.recv s (fromIntegral n))
     67     if   BS.null b
     68     then pure ()
     69     else do
     70       yield b
     71       loop (not lip)
     72 
     73 -- send on alternate sockets
     74 foxtrot
     75   :: MonadIO m
     76   => N.Socket
     77   -> N.Socket
     78   -> Consumer BS.ByteString m b
     79 foxtrot asock bsock = loop True where
     80   loop lip = do
     81     b <- await
     82     let s = if lip then asock else bsock
     83     liftIO $ NT.send s b
     84     loop (not lip)
     85 
     86 -- basic TCP coordination
     87 session
     88   :: (MonadIO m, DB.Binary b, DB.Binary c)
     89   => N.Socket
     90   -> Protocol m b c
     91   -> Effect m (PB.DecodingError, Producer BS.ByteString m ())
     92 session sock eval =
     93         deco
     94     >-> P.mapM eval
     95     >-> for cat PB.encode
     96     >-> send
     97   where
     98     recv = fromSocket sock 4096
     99     deco = PP.parsed PB.decode recv
    100     send = toSocket sock
    101 
    102 -- MITM TCP coordination
    103 dance
    104   :: (MonadIO m, DB.Binary b, DB.Binary c)
    105   => N.Socket
    106   -> N.Socket
    107   -> Protocol m b c
    108   -> Effect m (PB.DecodingError, Producer BS.ByteString m ())
    109 dance asock bsock eval =
    110         PP.parsed PB.decode recv
    111     >-> P.mapM eval
    112     >-> for cat PB.encode
    113     >-> foxtrot bsock asock
    114   where
    115     recv = rhumba asock bsock 4096
    116