hoovie-0.1.1: src/Hoovie/Messages.hs
module Hoovie.Messages (
BrowseType(..),
hoovieXml,
browseResponse,
contentDirectoryEvent,
connectionManagerEvent
) where
import Text.XML.Light (QName(..), CData(..), CDataKind(..), Content(..), Element(..), Attr(..), showContent)
import Data.Time.Format (formatTime)
import System.Locale (defaultTimeLocale)
import Text.Printf (printf)
import Data.Time (UTCTime(..), fromGregorian, secondsToDiffTime)
import Data.List (sortBy)
import Data.Ord (comparing)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import Hoovie.Resource
-- some helpers
infixr 9 !
(!) :: String -> String -> QName
"" ! name = QName name Nothing Nothing
ns ! name = QName name Nothing (Just ns)
infixr 8 ~=
(~=) :: QName -> String -> Attr
name ~= value = Attr name value
tag :: QName -> [Attr] -> [Content] -> Content
tag n as cs = Elem $ Element n as cs Nothing
text :: String -> [Content]
text s = [Text (CData CDataText s Nothing)]
xmlHeader :: B.ByteString
xmlHeader = BC.pack "<?xml version=\"1.0\" encoding=\"utf-8\"?>"
asString :: Content -> B.ByteString
asString x = xmlHeader `B.append` (BC.pack $ showContent x)
envelope :: Content -> Content
envelope xs =
tag ("s"!"Envelope") ["xmlns"!"s" ~= "http://schemas.xmlsoap.org/soap/envelope/", "s"!"encodingStyle" ~= "http://schemas.xmlsoap.org/soap/encoding/"] [
tag ("s"!"Body") [] [xs]
]
-- actual messages
hoovieXml :: String -> String -> String -> B.ByteString
hoovieXml url uuid pngUri = asString $
tag (""!"root") ["xmlns"!"dlna" ~= "urn:schemas-dlna-org:device-1-0", ""!"xmlns" ~= "urn:schemas-upnp-org:device-1-0"] [
tag (""!"specVersion") [] [
tag (""!"major") [] $ text "1",
tag (""!"minor") [] $ text "0"
],
tag (""!"URLBase") [] $ text url,
tag (""!"device") [] [
tag ("dlna"!"X_DLNADOC") ["xmlns"!"dlna" ~= "urn:schemas-dlna-org:device-1-0"] $ text "DMS-1.50",
tag ("dlna"!"X_DLNADOC") ["xmlns"!"dlna" ~= "urn:schemas-dlna-org:device-1-0"] $ text "M-DMS-1.50",
tag (""!"deviceType") [] $ text "urn:schemas-upnp-org:device:MediaServer:1",
tag (""!"friendlyName") [] $ text "Hoovie",
tag (""!"manufacturer") [] $ text "hoovie.org",
tag (""!"manufacturerURL") [] $ text "http://www.hoovie.org",
tag (""!"modelDescription") [] $ text "Hoovie - The Haskell Media Server",
tag (""!"modelName") [] $ text "Hoovie",
tag (""!"modelNumber") [] $ text "01",
tag (""!"modelURL") [] $ text "http://www.hoovie.org",
tag (""!"serialNumber") [] $ text "",
tag (""!"UPC") [] $ text "",
tag (""!"UDN") [] $ text ("uuid:" ++ uuid),
tag (""!"presentationURL") [] $ text (url ++ "/index.html"),
tag (""!"iconList") [] [
tag (""!"icon") [] [
tag (""!"mimetype") [] $ text "image/png",
tag (""!"width") [] $ text "128",
tag (""!"height") [] $ text "128",
tag (""!"depth") [] $ text "32",
tag (""!"url") [] $ text ('/' : pngUri)
]
],
tag (""!"serviceList") [] [
tag (""!"service") [] [
tag (""!"serviceType") [] $ text "urn:schemas-upnp-org:service:ContentDirectory:1",
tag (""!"serviceId") [] $ text "urn:upnp-org:serviceId:ContentDirectory",
tag (""!"SCPDURL") [] $ text "/static/UPnP_AV_ContentDirectory_1.0.xml",
tag (""!"controlURL") [] $ text "/upnp/control/content_directory",
tag (""!"eventSubURL") [] $ text "/upnp/event/content_directory"
],
tag (""!"service") [] [
tag (""!"serviceType") [] $ text "urn:schemas-upnp-org:service:ConnectionManager:1",
tag (""!"serviceId") [] $ text "urn:upnp-org:serviceId:ConnectionManager",
tag (""!"SCPDURL") [] $ text "/static/UPnP_AV_ConnectionManager_1.0.xml",
tag (""!"controlURL") [] $ text "/upnp/control/connection_manager",
tag (""!"eventSubURL") [] $ text "/upnp/event/connection_manager"
]
]
]
]
data BrowseType = BrowseObject
| BrowseChildren
deriving (Eq, Ord, Show)
data DIDLItem = Folder { foObjectId :: String, foParentId :: String, foTitle :: String, foChildCount :: Int }
| Video { viResource :: Resource }
deriving (Eq, Ord, Show)
browseResponse :: String -> [Resource] -> BrowseType -> String -> Int -> Int -> Int -> B.ByteString
browseResponse url resources browseType objectId start count updateId = asString $ envelope $
let (object, children) = getObject resources objectId
items = if browseType == BrowseObject then [object] else children
total = length items
in tag ("u"!"BrowseResponse") ["xmlns"!"u" ~= "urn:schemas-upnp-org:service:ContentDirectory:1"] [
tag (""!"Result") [] $ text (showContent $ didl url items start count),
tag (""!"NumberReturned") [] $ text (show $ min count total),
tag (""!"TotalMatches") [] $ text (show total),
tag (""!"UpdateID") [] $ text (show updateId)
]
defaultDate :: UTCTime
defaultDate = UTCTime (fromGregorian 2001 1 1) (secondsToDiffTime 0)
rootId, latestId, allId :: String
rootId = "0"
latestId = "latest"
allId = "all"
rootFolder, latestFolder, allFolder :: [Resource] -> DIDLItem
rootFolder _ = Folder rootId "0" "Movies" 2
latestFolder resources = Folder latestId "0" "Latest" (min 10 $ length resources)
allFolder resources = Folder allId "0" "All" (length resources)
getObject :: [Resource] -> String -> (DIDLItem, [DIDLItem])
getObject resources objectId
| objectId == rootId = (rootFolder resources, [ latestFolder resources, allFolder resources ])
| objectId == latestId = (latestFolder resources, latestItems resources)
| objectId == allId = (allFolder resources, allItems resources)
| otherwise = (rootFolder resources, [])
latestItems :: [Resource] -> [DIDLItem]
latestItems resources = map Video $ take 10 $ sortBy (flip $ comparing reDate) resources
allItems :: [Resource] -> [DIDLItem]
allItems resources = map Video $ sortBy (comparing reTitle) resources
didl :: String -> [DIDLItem] -> Int -> Int -> Content
didl url items start count =
tag (""!"DIDL-Lite") [""!"xmlns" ~= "urn:schemas-upnp-org:metadata-1-0/DIDL-Lite/", "xmlns"!"dc" ~= "http://purl.org/dc/elements/1.1/", "xmlns"!"upnp" ~= "urn:schemas-upnp-org:metadata-1-0/upnp/"] $
(map (didlItem url) . take count . drop start $ items)
didlItem :: String -> DIDLItem -> Content
didlItem url (Folder fid pid title count) =
tag (""!"container") [""!"id" ~= fid, ""!"childCount" ~= show count, ""!"parentID" ~= pid, ""!"restricted" ~= "true"] [
tag (""!"res") [""!"protocolInfo" ~= "http-get:*:image/jpeg:DLNA.ORG_PN=JPEG_TN"] $ text (url ++ "/folder/" ++ fid),
tag ("dc"!"title") [] $ text title,
tag ("dc"!"date") [] $ text (formatDate defaultDate),
tag ("upnp"!"class") [] $ text "object.container.storageFolder"
]
didlItem url (Video resource) =
let rid = show $ reID resource in
tag (""!"item") [""!"id" ~= ("0$" ++ rid), ""!"parentID" ~= "0", ""!"restricted" ~= "true"] [
tag ("dc"!"title") [] $ text (reTitle resource),
tag ("dc"!"date") [] $ text (formatDate $ reDate resource),
tag ("upnp"!"class") [] $ text "object.item.videoItem",
tag ("upnp"!"albumArtURI") ["xmlns"!"dlna" ~= "urn:schemas-dlna-org:metadata-1-0/", "dlna"!"profileID" ~= "JPEG_TN"] $ text (url ++ "/icon/" ++ rid),
tag (""!"res") [""!"protocolInfo" ~= "http-get:*:image/jpeg:DLNA.ORG_PN=JPEG_TN"
] $ text (url ++ "/icon/" ++ rid),
tag (""!"res") [ "xmlns"!"dlna" ~= "urn:schemas-dlna-org:metadata-1-0/"
, ""!"protocolInfo" ~= "http-get:*:video/mpeg:DLNA.ORG_PN=MPEG_PS_NTSC;DLNA.ORG_OP=10"
, ""!"duration" ~= (formatDuration $ reDuration resource)
, ""!"resolution" ~= (formatResolution $ reResolution resource)
, ""!"bitrate" ~= (show $ reBitrate resource)
, ""!"nrAudioChannels" ~= (show $ reBitrate resource)
, ""!"sampleFrequency" ~= (show $ reSampleFreq resource)
] $ text (url ++ "/stream/" ++ rid)
]
connectionManagerEvent :: B.ByteString
connectionManagerEvent = asString $
tag ("e"!"propertyset") ["xmlns"!"e" ~= "urn:schemas-upnp-org:event-1-0", "xmlns"!"s" ~= "urn:schemas-upnp-org:service:ConnectionManager:1"] [
tag ("e"!"property") [] [ tag (""!"SinkProtocolInfo") [] [] ],
tag ("e"!"property") [] [ tag (""!"SourceProtocolInfo") [] [] ],
tag ("e"!"property") [] [ tag (""!"CurrentConnectionIDs") [] [] ]
]
contentDirectoryEvent :: B.ByteString
contentDirectoryEvent = asString $
tag ("e"!"propertyset") ["xmlns"!"e" ~= "urn:schemas-upnp-org:event-1-0", "xmlns"!"s" ~= "urn:schemas-upnp-org:service:ContentDirectory:1"] [
tag ("e"!"property") [] [ tag (""!"TransferIDs") [] [] ],
tag ("e"!"property") [] [ tag (""!"ContainerUpdateIDs") [] [] ],
tag ("e"!"property") [] [ tag (""!"SystemUpdateID") [] (text "1") ]
]
formatDate :: UTCTime -> String
formatDate = formatTime defaultTimeLocale "%FT%T"
formatDuration :: Int -> String
formatDuration d = printf "%02d:%02d:%02d.00" (d `div` 3600) ((d `div` 60) `mod` 60) (d `mod` 60)
formatResolution :: (Int, Int) -> String
formatResolution (x, y) = printf "%dx%d" x y