module Hoovie.SSDP (
        SSDPServiceItem(..),
        SSDPService(..),
        SSDPHandle,
        startSsdpServer,
        stopSsdpServer,
        getUUID,
        getURL
    ) where

import Network.Socket           (socket, sendTo, recvFrom, sClose, SockAddr, Family(AF_INET), SocketType(Datagram), PortNumber)
import Network.Multicast        (setTimeToLive, multicastSender, multicastReceiver, addMembership)
import Control.Exception.Base   (bracket)
import Control.Concurrent       (forkIO, ThreadId, killThread, threadDelay)
import Control.Monad            (forever, forM_)
import Data.List                (intercalate, isPrefixOf, isInfixOf)
import Data.Time.Clock          (getCurrentTime)
import Data.Time.Format         (formatTime)
import System.Locale            (defaultTimeLocale)
import Network.Info             (NetworkInterface, MAC(..), mac, ipv4)
import Text.Printf              (printf)

-- TODO
-- * stop instead of kill threads, and send byebye
-- * catch all exceptions in the threads to make sure they keep running

data SSDPServiceItem = SSDPMediaServer
                     | SSDPContentDirectory
                     | SSDPConnectionManager
                     deriving (Eq, Ord, Show)

data SSDPService = SSDPService { 
        ssInterface      :: NetworkInterface,
        ssPort           :: Int,
        ssURI            :: String,
        ssProductName    :: String,
        ssProductVersion :: String,
        ssServiceItems   :: [SSDPServiceItem]
    } deriving (Show)

data SSDPHandle = SSDPHandle ThreadId ThreadId String String

ssdpIP :: String
ssdpIP   = "239.255.255.250"

ssdpPort :: PortNumber
ssdpPort = 1900

serviceUri :: SSDPServiceItem -> String
serviceUri SSDPMediaServer          = "urn:schemas-upnp-org:device:MediaServer:1"
serviceUri SSDPContentDirectory     = "urn:schemas-upnp-org:service:ContentDirectory:1"
serviceUri SSDPConnectionManager    = "urn:schemas-upnp-org:service:ConnectionManager:1"

startSsdpServer :: SSDPService -> IO SSDPHandle
startSsdpServer (SSDPService interface port uri productName productVersion services) = do
    let uuid   = getUUIDFromMacAddress interface
    let server = "Linux/2.6 UPnP/1.0 " ++ productName ++ "/" ++ productVersion
    let base   = "http://" ++ show (ipv4 interface) ++ ":" ++ show port
    let url    = base ++ uri
    a <- forkIO $ sendAlive uuid url server services
    b <- forkIO $ listen    uuid url server services
    return $ SSDPHandle a b base uuid

stopSsdpServer :: SSDPHandle -> IO ()
stopSsdpServer (SSDPHandle a b _ _) = do
    killThread a
    killThread b

getUUID :: SSDPHandle -> String
getUUID (SSDPHandle _ _ _ uuid) = uuid

getURL :: SSDPHandle -> String
getURL (SSDPHandle _ _ url _) = url

getUUIDFromMacAddress :: NetworkInterface -> String
getUUIDFromMacAddress interface =
        toUUID $ if mac interface == MAC 0 0 0 0 0 0
                    then MAC 18 29 53 79 76 25
                    else mac interface
    where
        toUUID (MAC a b c d e f) = take 16 $ "35" ++ (printf "%02d%02d%02d%02d%02d%02d" a b c d e f) ++ "53"

messageTypes :: String -> [SSDPServiceItem] -> [String]
messageTypes uuid services = ["upnp:rootdevice", uuid] ++ map serviceUri services

listen :: String -> String -> String -> [SSDPServiceItem] -> IO ()
listen uuid url server services = forever $ do
    (msg, addr) <- receive
    -- putStr msg
    if "M-SEARCH" `isPrefixOf` msg 
        then forM_ (messageTypes uuid services) $ \msgType -> do if msgType `isInfixOf` msg then sendDiscover uuid url server addr msgType else return ()
        else return ()
    
getRFC1123Date :: IO String
getRFC1123Date = do
    -- rfc1123-date = wkday "," SP date1 SP time SP "GMT"
    -- wkday        = "Mon" | "Tue" | "Wed" | "Thu" | "Fri" | "Sat" | "Sun"
    -- date1        = 2DIGIT SP month SP 4DIGIT         ; day month year (e.g., 02 Jun 1982)
    -- time         = 2DIGIT ":" 2DIGIT ":" 2DIGIT      ; 00:00:00 - 23:59:59
    -- Example: Sun, 06 Nov 1994 08:49:37 GMT
    now <- getCurrentTime
    return $ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT" now

sendDiscover :: String -> String -> String -> SockAddr -> String -> IO ()
sendDiscover uuid url server addr st = do
    date <- getRFC1123Date
    sendReply addr $ makeMessage "HTTP/1.1 200 OK" [
            ("CACHE-CONTROL", "max-age=1800"),
            ("DATE", date),
            ("EXT", ""),
            ("LOCATION", url),
            ("SERVER", server),
            ("ST", (if st == uuid then "uuid:" else "") ++ st),
            ("USN", "uuid:" ++ uuid ++ (if st == uuid then "" else "::" ++ st)),
            ("Content-Length", "0")
        ]

sendAlive :: String -> String -> String -> [SSDPServiceItem] -> IO ()
sendAlive uuid url server services = forever $ do
    send $ map (makeAliveMessage uuid url server) (messageTypes uuid services)
    threadDelay 600000000

makeAliveMessage :: String -> String -> String -> String -> String
makeAliveMessage uuid url server nt = makeMessage "NOTIFY * HTTP/1.1" [
        ("HOST", "239.255.255.250:1900"),
        ("CACHE-CONTROL", "max-age=1800"),
        ("LOCATION", url),
        ("NT", (if nt == uuid then "uuid:" else "") ++ nt),
        ("NTS", "ssdp:alive"),
        ("SERVER", server),
        ("USN", "uuid:" ++ uuid ++ (if nt == uuid then "" else "::" ++ nt))
    ]

-- makeByebyeMessage :: String -> String -> String
-- makeByebyeMessage uuid nt = makeMessage "NOTIFY * HTTP/1.1" [
--         ("HOST", "239.255.255.250:1900"),
--         ("NT", nt),
--         ("NTS", "ssdp:byebye"),
--         ("USN", if nt == uuid then uuid else uuid ++ "::" ++ nt)
--     ]

makeMessage :: String -> [(String, String)] -> String
makeMessage method headers = 
    method ++ "\r\n" ++
    (intercalate "\r\n" [ key ++ ": " ++ value | (key, value) <- headers ]) ++
    "\r\n\r\n"

sendReply :: SockAddr -> String -> IO ()
sendReply addr message = do
    bracket
        (socket AF_INET Datagram 0)
        (sClose)
        (\sock -> forM_ ([1..3] :: [Int]) $ \_ -> do
            go sock message
            threadDelay 500000)
    where
        go _    []  = return ()
        go sock msg = do 
            sent <- sendTo sock msg addr
            go sock $ drop sent msg

send :: [String] -> IO ()
send messages = do
    bracket
        (multicastSender ssdpIP ssdpPort)
        (sClose . fst)
        (\(sock, addr) -> do
            setTimeToLive sock 4
            addMembership sock ssdpIP
            forM_ ([1..3] :: [Int]) $ \_ -> do
                forM_ messages $ \m -> do
                    go sock addr m
                threadDelay 500000)
    where
        go _    _    []  = return ()
        go sock addr msg = do 
            sent <- sendTo sock msg addr
            go sock addr $ drop sent msg

receive :: IO (String, SockAddr)
receive = do
    bracket
        (multicastReceiver ssdpIP ssdpPort)
        (sClose)
        (\sock -> do 
            (msg, _, addr) <- recvFrom sock 1024
            return (msg, addr))