SOAP.hs

{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
module Hoovie.SOAP (
        hoovieXmlUri,
        soapHandler,
        staticSendFile
    ) where

import Text.XML.Light         (parseXMLDoc, findElement, QName(..), Element(..), strContent)
import Text.XML.Light.Lexer   (XmlSource)
import Data.String            (IsString)
import Data.FileEmbed         (embedFile)
import Control.Applicative    ((<|>))
import Control.Monad.IO.Class (liftIO)

import qualified Data.ByteString       as B
import qualified Data.ByteString.Char8 as BC

import Snap.Core

import Hoovie.Messages
import Hoovie.Monitor
import Hoovie.Util

hoovieXmlUri :: String
hoovieXmlUri = "static/hoovie.xml"

hooviePngUri :: String
hooviePngUri = "static/hoovie.png"

soapHandler :: String -> String -> FilePath -> Snap ()
soapHandler url uuid db =
    path "static/UPnP_AV_ConnectionManager_1.0.xml" (staticSendXml $(embedFile "static/UPnP_AV_ConnectionManager_1.0.xml"))  <|>
    path "static/UPnP_AV_ContentDirectory_1.0.xml"  (staticSendXml $(embedFile "static/UPnP_AV_ContentDirectory_1.0.xml"))   <|>
    path (BC.pack hoovieXmlUri)                     (staticSendXml $ hoovieXml url uuid hooviePngUri)                        <|>
    path (BC.pack hooviePngUri)                     (staticSendFile "image/png" $(embedFile "static/hoovie.png"))            <|>
    subscribeAction uuid                                                                                                     <|>
    soapAction url db

subscribeAction :: String -> Snap ()
subscribeAction uuid = method (Method "SUBSCRIBE") (
    path "upnp/event/connection_manager" (staticSendEvent uuid $ connectionManagerEvent) <|>
    path "upnp/event/content_directory"  (staticSendEvent uuid $ contentDirectoryEvent))

soapAction :: String -> FilePath -> Snap ()
soapAction url db = method POST $ do
    action <- getsRequest (getHeader "SOAPACTION")
    case action of
        Nothing -> pass
        Just a  -> handleSoapAction url db a

staticSendEvent :: String -> B.ByteString -> Snap ()
staticSendEvent uuid bytes = do
    modifyResponse $ setHeader "SID" (BC.pack $ "uuid:" ++ uuid)
                   . setHeader "TIMEOUT" "Second-1800"
    staticSendXml bytes

staticSendXml :: B.ByteString -> Snap ()
staticSendXml = staticSendFile "text/xml; charset=\"utf-8\""

staticSendFile :: String -> B.ByteString -> Snap ()
staticSendFile contentType bytes = do
    modifyResponse $ setContentLength (fromIntegral $ B.length bytes)
                   . setContentType   (BC.pack contentType)
    writeBS bytes

handleSoapAction :: (Eq a, Data.String.IsString a) => String -> FilePath -> a -> Snap ()
handleSoapAction _   _  "\"urn:schemas-upnp-org:service:ConnectionManager:1#GetProtocolInfo\""      = staticSendXml $(embedFile "static/get-protocol-info.xml")
handleSoapAction _   _  "\"urn:schemas-upnp-org:service:ContentDirectory:1#GetSortCapabilities\""   = staticSendXml $(embedFile "static/get-sort-capabilities.xml")
handleSoapAction _   _  "\"urn:schemas-upnp-org:service:ContentDirectory:1#GetSearchCapabilities\"" = staticSendXml $(embedFile "static/get-search-capabilities.xml")
handleSoapAction _   _  "\"urn:schemas-upnp-org:service:ContentDirectory:1#GetSystemUpdateID\""     = staticSendXml $(embedFile "static/get-system-update-id.xml")
handleSoapAction url db "\"urn:schemas-upnp-org:service:ContentDirectory:1#Browse\"" = do
    body <- getRequestBody
    case parseBrowseRequest body of
        Just (objectId, start, count, browseFlag) -> do
            resources <- liftIO $ getResources db
            staticSendXml $ browseResponse url resources (if browseFlag == "BrowseMetadata" then BrowseObject else BrowseChildren) objectId start count 1
        Nothing -> pass
handleSoapAction _ _ _ = pass

parseBrowseRequest :: XmlSource s => s -> Maybe (String, Int, Int, String)
parseBrowseRequest xml = do
    doc           <- parseXMLDoc xml
    objectId      <- getTagValue doc $ QName "ObjectID" Nothing Nothing
    startIndexStr <- getTagValue doc $ QName "StartingIndex" Nothing Nothing
    reqCountStr   <- getTagValue doc $ QName "RequestedCount" Nothing Nothing
    browseFlag    <- getTagValue doc $ QName "BrowseFlag" Nothing Nothing
    -- filter        <- getTagValue doc $ QName "Filter" Nothing Nothing
    startIndex    <- maybeRead startIndexStr
    reqCount      <- maybeRead reqCountStr
    return (objectId, startIndex, reqCount, browseFlag)

getTagValue :: Element -> QName -> Maybe String
getTagValue doc item = case findElement item doc of
                        Nothing -> Nothing
                        Just el -> Just $ strContent el