hoovie-0.1.1: src/Hoovie/SSDP.hs
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))