Http.hs

module Conjure.UI.Http (httpServer) where

import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception

import Conjure.Types
import Conjure.Utils
import Conjure.Piecemap
import Conjure.Network.Peer ()
import Conjure.STM.PeerCtrl
import Conjure.Debug

import System.IO
import GHC.Conc (unsafeIOToSTM)
import Data.Map (Map)
import Data.List
import Data.Array.Diff hiding ((!))
import qualified Data.ByteString as BS
import Network                ( PortID(..), PortNumber, listenOn, accept )

import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import Text.Html

httpServer :: TVar [ConnectedPeer]
          -> TVar (Map BS.ByteString ActiveTorrent)
          -> PortNumber
          -> IO ()
httpServer connectedPeers torrentMap port
    = do sock <- listenOn (PortNumber port)
         debug $ "HTTP UI Server is awaiting connections. Socket: " ++ show sock
         let loop = do (hndle, hostname, prt) <- accept sock
                       debug $ "HTTP UI server got connect from: " ++
                               show hostname ++ ":" ++ show prt ++
                               " (handle: " ++ show hndle ++ ")"
                       forkIO (handleUIrequest connectedPeers torrentMap hndle `finally` hClose hndle)
                       loop
         loop

handleUIrequest :: TVar [ConnectedPeer] -> TVar (Map k ActiveTorrent)
                                               -> Handle
                                               -> IO ()
handleUIrequest connectedPeers torrentMap hndle =
  do request <- hGetLine hndle
     page <- atomically $
             do peers <- readTVar connectedPeers
                torrents <- readTVar torrentMap
                at_rows <- mapM dumpActiveTorrent (zip ones (Map.elems torrents))
                peer_rows <- mapM dumpConnectedPeer (zip ones peers)
                return $ body <<
                         h1 << "Request:" +++ request +++
                         table![border 1] <<
                           ( ( th << "Torrent map:" <-> th << "Connected peers:" )
                             </>
                             ( td![valign "top"] << ( table![border 1] << at_rows ) <->
                               td![valign "top"] << ( table![border 1] <<
                                                      ( (th << "#"                <->
                                                         th << "Choke"            <-> th << "Interest"       <->
                                                         th << "Pending" <->
                                                         th << "Download kb/s"    <-> th << "Upload kb/s"    <->
                                                         th << "Complete"
                                                        )
                                                        </>
                                                        (tr << peer_rows)
                                                      )
                                                    )
                             )
                           )
     hPutStr hndle $ renderHtml page
  where
  ones :: [Int]
  ones = [1..]
  dumpActiveTorrent (n,at) =
    do up <- readTVar $ atUploaded at
       down <- readTVar $ atDownloaded at
       piece_map <- readTVar $ atPiecemap at
       pieces <- do pmap <- readTVar $ atPieces at
                    mapM (\(idx,q) -> do s<-readTVar (pStatus q); return (idx,s)) (IntMap.toList pmap)
       let files = tFiles' (tInfo $ atTorrent at)
       return $ td << ("Torrent number " +++ show n) <->
                  ( ( td << "Our Peer ID:" <-> td << (show $ atPeerId at) <->
                      td << "Uploaded:" <->  td << (show up) <->
                      td << "Downloaded:" <-> td << (show down)
                    )
                    </>
                    ( td <<"Piecemap:"  <-> td << drawPiecemap piece_map "")
                    </>
                    ( td << "Pieces:" <-> td << (foldr (\x y -> x +++ br +++ y) noHtml $ map show pieces))
                    </>
                    ( td << "Files:" <-> files )
                  )

  tFiles' (SingleFile len nme plen _) =
    td << nme <-> td << (show len +++ " bytes") <-> td << (show plen ++ " bytes per piece)")
  tFiles' (MultiFile files nme plen _) =
    (td << nme <-> td << (show plen ++ " bytes per piece)"))
    </>
    (aboves $ map tFile' files)
  tFile' (TorrentFile len path) =
    td << path <-> td << (show len +++ " bytes")

  dumpConnectedPeer (n,cp) =
    do lChoke <- getLocalChoke cp
       rChoke <- getRemoteChoke cp
       lInterest <- getLocalInterest cp
       rInterest <- getRemoteInterest cp
       pending <- readTVar (cpPendingBlocks cp)
       now <- unsafeIOToSTM $ getCurrentTime
       downBps <- if lInterest && not rChoke
                  then fmap (Just .flip div 1024) $ getTiming  now 20000 (cpDownloadTimings cp)
                  else return Nothing
       upBps <- if rInterest && not lChoke
                then fmap (Just .flip div 1024) $ getTiming  now 20000 (cpUploadTimings cp)
                else return Nothing
       piecemap <- readTVar (cpPiecemap cp)
       let complete = fromIntegral (length $ filter id $ elems piecemap) / (fromIntegral (rangeSize $ bounds piecemap) :: Double)
       return $ td << (show n) <->
                td << (show (lChoke,rChoke)) <-> td<< (show (lInterest,rInterest)) <->
                td << (show (Map.size pending)) <->
                td << (show downBps) <->td<<(show upBps)<->
                td << (show (complete * 100) ++ "%")