module P2PPackage9 where

import Network.Socket (HostAddress, inet_ntoa, inet_addr)
import Network.BSD (getHostName, getHostByName, hostAddress)
import List (genericLength, genericSplitAt, intersperse)
import Char (chr, ord)
import GHC.IOBase (unsafePerformIO)

type MD5 = String

data P2PPackage =
    P2PServerListPackage [HostAddress] [HostAddress] [HostAddress]
  | P2PSearchReqPackage  [HostAddress] String
  | P2PSearchRespPackage [(HostAddress, MD5, Integer{-Len Cont-}
			  ,String{-Name-})
			 ]
  | P2PResourcePackage Bool{-Resp-} Bool{-NAVAIL-} 
       HostAddress MD5 Integer{-FROM-} Integer{-TO-} String{-Cont-}

-- printer for P2P packages

instance Show P2PPackage where
  showsPrec _ (P2PServerListPackage hopIPs posIPs negIPs) =
    showString (map chr [0, length hopIPs, length posIPs, length negIPs])
      . showIPs hopIPs . showIPs posIPs . showIPs negIPs

  showsPrec _ (P2PSearchReqPackage hopIPs searchString) =
    showString (map chr [128, length hopIPs, 255, 255])
      . showIPs hopIPs 
      . showXDRInt (genericLength searchString) 
      . showString searchString

  showsPrec _ (P2PSearchRespPackage chunks) =
    showString (map chr [196, 255, length chunks, 255])
      . showMore showP2PSearchRespChunk chunks

  showsPrec _ (P2PResourcePackage isResp isNAvail ip md5 from to content) = 
    showString 
      (map chr [64, 255, if isResp then 1 else 0, if isNAvail then 1 else 0])
      . showIP ip 
      . showString md5 
      . showXDRInt from 
      . showXDRInt to 
      . showString content

showP2PSearchRespChunk (ip, md5, lenCont, cont) =
  showIP ip 
    . showString md5 
    . showXDRInt lenCont 
    . showXDRInt (genericLength cont)
    . showString cont

showXDRInt i =
  let (q0, r0) = i `quotRem` 256
      (q1, r1) = q0 `quotRem` 256
      (q2, r2) = q1 `quotRem` 256
  in showString $ map (chr . fromInteger) [q2, r2, r1, r0]

showIPs = showMore showIP 

showIP = showString . hostAddressToNetworkByteOrderedString

showMore _ [] = id
showMore showElem (x:xs) = showElem x . showMore showElem xs

-- parser for P2P packages

parsePackage :: String -> Maybe P2PPackage
parsePackage (typ : hops : para1 : para2 : dataStuff)
  | typ == (chr 0) =
    parseServerListPackage (ord hops) (ord para1) (ord para2) dataStuff
  | typ == (chr 128) =
    parseSearchReqPackage (ord hops) (ord para1) (ord para2) dataStuff
  | typ == (chr 196) =
    parseSearchRespPackage (ord hops) (ord para1) (ord para2) dataStuff
  | typ == (chr 64) =
    parseResourcePackage (ord hops) (ord para1) (ord para2) dataStuff
parsePackage _ =  -- wrong package format 
  Nothing

parseServerListPackage :: Int -> Int -> Int -> String -> Maybe P2PPackage
parseServerListPackage nrHops nrPos nrNeg dataStuff = do
  let (hopIPStrs, dataStuff')  = splitAt (nrHops * 4) dataStuff
      (posIPStrs, dataStuff'') = splitAt (nrPos * 4) dataStuff'
      (negIPStrs, rest)        = splitAt (nrNeg * 4) dataStuff''
  hopIPs <- parseIPs hopIPStrs
  posIPs <- parseIPs posIPStrs
  negIPs <- parseIPs negIPStrs
  parseEmpty rest
  return $ P2PServerListPackage hopIPs posIPs negIPs

parseSearchReqPackage :: Int -> Int -> Int -> String -> Maybe P2PPackage
parseSearchReqPackage nrHops _ _ dataStuff = do
  let (hopIPStrs, dataStuff') = splitAt (nrHops * 4) dataStuff
      (searchStringLenStr, dataStuff'') = splitAt 4 dataStuff'
  searchStringLen <- parseXDRInt searchStringLenStr
  let (searchString, rest) = genericSplitAt searchStringLen dataStuff''
  hopIPs <- parseIPs hopIPStrs
  parseEmpty rest
  return $ P2PSearchReqPackage hopIPs searchString

parseSearchRespPackage :: Int -> Int -> Int -> String -> Maybe P2PPackage
parseSearchRespPackage _ nrChunks _ dataStuff = do
  (rest, chunks) <- loop nrChunks parseSearchRespChunk dataStuff
  parseEmpty rest
  return $ P2PSearchRespPackage chunks

parseSearchRespChunk :: String -> 
                        Maybe (String, (HostAddress, MD5, Integer, String))
parseSearchRespChunk str = do
  let (ipStr, rest) = splitAt 4 str
      (md5, rest') = splitAt 16 rest
      (lenContStr, rest'') = splitAt 4 rest'
      (lenDataStr, rest''') = splitAt 4 rest''
  ip <- parseIP ipStr
  lenCont <- parseXDRInt lenContStr
  lenData <- parseXDRInt lenDataStr
  let (cont , rest'''') = genericSplitAt lenData rest'''
  return $ (rest'''', (ip, md5, lenCont, cont))    
      
parseResourcePackage :: Int -> Int -> Int -> String -> Maybe P2PPackage
parseResourcePackage _ isResp isNAvail dataStuff = do
  let resp = isResp == 1
      nAvail = isNAvail == 1
      (ipStr, rest) = splitAt 4 dataStuff
      (md5, rest') = splitAt 16 rest
      (fromStr, rest'') = splitAt 4 rest'
      (toStr, rest''') = splitAt 4 rest''
  ip <- parseIP ipStr
  from <- parseXDRInt fromStr
  to <- parseXDRInt toStr
  let (content, rest'''') = genericSplitAt (to - from) rest'''
  parseEmpty rest''''
  return $ P2PResourcePackage resp nAvail ip md5 from to content

parseIP :: String -> Maybe HostAddress
parseIP [c1,c2,c3,c4] = 
  Just $ networkByteOrderedStringToHostAddress (c1, c2, c3, c4)
parseIP _ =
  Nothing

parseIPs :: String -> Maybe [HostAddress]
parseIPs [] = return []
parseIPs (c1:c2:c3:c4:rest) = do
  ips <- parseIPs rest
  let ip = networkByteOrderedStringToHostAddress (c1, c2, c3, c4) 
  return (ip:ips)
parseIPs _ = Nothing

parseXDRInt :: String -> Maybe Integer
parseXDRInt [c0,c1,c2,c3] = 
  Just $ 256 * (256 * (256 * (toI c0) + (toI c1)) + (toI c2)) + toI c3
  where toI = toInteger . ord
parseXDRInt _ = Nothing

hostAddressToNetworkByteOrderedString :: HostAddress -> String
hostAddressToNetworkByteOrderedString n = 
  let str = unsafePerformIO $ inet_ntoa n
      is = tokenize (== '.') str
  in map (chr . read) is

networkByteOrderedStringToHostAddress :: (Char, Char, Char, Char) -> HostAddress
networkByteOrderedStringToHostAddress (c1, c2, c3, c4) =
  let il = [show (ord c1), show (ord c2), show (ord c3), show (ord c4)]
      str = concat $ intersperse "." il
  in unsafePerformIO (inet_addr str)

parseEmpty [] = Just ()
parseEmpty _ = Nothing

--

getLocalHostAddress :: IO HostAddress
getLocalHostAddress = do
  hostName <- getHostName
  hostEntry <- getHostByName hostName
  return $ hostAddress hostEntry

tokenize :: (a -> Bool) -> [a] -> [[a]]
tokenize p str =
  case break p str of
    ([], _) -> []
    (f , (_:rest)) -> (f : tokenize p rest)
    (f , _) -> [f]

loop :: (Num a , Monad m) => a -> (c -> m (c, b)) -> c -> m (c, [b])
loop 0 _ state  =
  return (state, [])
loop n action state = do
  (state', r) <- action state
  (state'', rs) <- loop (n-1) action state'
  return (state'', (r:rs))