diff --git a/hums.cabal b/hums.cabal --- a/hums.cabal +++ b/hums.cabal @@ -1,5 +1,5 @@ Name: hums -Version: 0.3.1 +Version: 0.3.2 Synopsis: Haskell UPnP Media Server Description: A simple UPnP Media Server. . @@ -11,51 +11,49 @@ Build-type: Simple Author: Bardur Arantsson Maintainer: Bardur Arantsson -Build-Depends: base == 4.*, - haskell98, - network >= 2.2.0.1, - HTTP >= 4000.0.8, - filepath >= 1.1.0.0, - parsec >= 2.1.0.0 && < 3.0, - regex-compat >= 0.91, - unix >= 2.3.0.0, - directory >= 1.0.0.0, - containers >= 0.1.0.1, - uuid >= 1.0.0, - bytestring >= 0.9.0.1, - utf8-string == 0.3.*, - MissingH >= 1.0.1, - hxt == 9.*, - ConfigFile >= 1.0.5, - mtl >= 1.1.0.2, - transformers == 0.2.*, - network-bytestring >= 0.1.2.1 && <0.2 data-dir: data data-files: hums.cfg www/images/hums.jpg www/services/ConnectionManager/description.xml www/services/ContentDirectory/description.xml -Executable: hums -Extensions: Arrows GeneralizedNewtypeDeriving -ghc-options: -Wall -fno-warn-unused-matches -threaded -hs-source-dirs: src -Main-is: Main.hs -Other-modules: Paths_hums - HttpExtra - StorableExtra - URIExtra - SimpleServiceDiscoveryProtocol - HttpExtra - HttpMonad - Service - Handlers - Configuration - Soap - DirectoryUtils - HttpServer - MimeType - Action - Object - Didl - SendFile +Executable hums + Build-Depends: base == 4.* + , haskell98 + , network == 2.3.* + , HTTP == 4000.1.* + , filepath >= 1.1.0.0 + , parsec >= 2.1.0.0 && < 3.0 + , unix >= 2.3.0.0 + , directory >= 1.0.0.0 + , containers >= 0.1.0.1 + , uuid >= 1.2.1 && < 1.3 + , bytestring >= 0.9.0.1 + , MissingH >= 1.0.1 + , hxt >= 9.0.1 + , ConfigFile >= 1.0.5 + , mtl == 2.0.* + , transformers == 0.2.* + , hashmap == 1.1.* + , text == 0.10.* + , HaXml == 1.20.* + Extensions: Arrows GeneralizedNewtypeDeriving + ghc-options: -Wall -fno-warn-unused-matches -threaded + hs-source-dirs: src + Main-is: Main.hs + Other-modules: Action + Configuration + DirectoryUtils + Handlers + HttpExtra + HttpMonad + HttpServer + MimeType + Object + Paths_hums + SendFile + Service + SimpleServiceDiscoveryProtocol + Soap + StorableExtra + URIExtra diff --git a/src/Didl.hs b/src/Didl.hs deleted file mode 100644 --- a/src/Didl.hs +++ /dev/null @@ -1,35 +0,0 @@ -{- - hums - The Haskell UPnP Server - Copyright (C) 2009 Bardur Arantsson - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . --} - -module Didl ( mkDidl - ) where - -import Text.XML.HXT.Arrow - --- Create a DIDL-Lite element with namespace declarations. -mkDidl :: ArrowXml a => [a XmlTree XmlTree] -> a XmlTree XmlTree -mkDidl es = - selem "dummy" -- Avoids the XML declaration when HXT generates the XML. - [ mkelem "DIDL-Lite" [ sattr "xmlns:dc" dcNs - , sattr "xmlns:upnp" upnpNs - , sattr "xmlns" ns ] - es ] - where - dcNs = "http://purl.org/dc/elements/1.1/" - upnpNs = "urn:schemas-upnp-org:metadata-1-0/upnp/" - ns = "urn:schemas-upnp-org:metadata-1-0/DIDL-Lite/" diff --git a/src/Handlers.hs b/src/Handlers.hs --- a/src/Handlers.hs +++ b/src/Handlers.hs @@ -29,7 +29,6 @@ import Network.HTTP.Headers import Network.StreamSocket() import Service -import Text.Regex import Text.Printf import Action import System.IO (withFile, hFileSize, IOMode(..)) @@ -37,11 +36,12 @@ import Object import HttpExtra import System.FilePath -import Data.Maybe (isJust) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as L +import Data.List (isInfixOf) import Data.IORef import HttpMonad import Control.Monad.Trans.Class (lift) -import Data.ByteString.UTF8 (fromString) import Control.Monad.IO.Class (MonadIO) type State = (Configuration, MediaServerConfiguration, ApplicationInformation, [DeviceType], IORef Objects) @@ -117,58 +117,50 @@ -- Regular expressions for avoiding relative URLs. These -- are overly conservative, but what the heck... -dotDotSlash :: Regex -dotDotSlash = mkRegex "\\.\\./" -slashDotDot :: Regex -slashDotDot = mkRegex "/\\.\\." +dotDotSlash :: String +dotDotSlash = "../" +slashDotDot :: String +slashDotDot = "/.." -- Handler for the root description. -rootDescriptionHandler :: State -> [String] -> HttpT IO () -rootDescriptionHandler (c,mc,ai,s,_) gs = do +rootDescriptionHandler :: State -> HttpT IO () +rootDescriptionHandler (c,mc,ai,s,_) = do logMessage "Got request for root description." - xml <- lift $ generateDescriptionXml c mc s - sendXml xml + sendXml $ generateDescriptionXml c mc s logMessage "Sent root description." -- Handle static files. -staticHandler :: String -> [String] -> HttpT IO () -staticHandler root gs = do - logMessage $ "Got request for static content: " ++ show gs - case gs of - [p] -> if isJust (matchRegex dotDotSlash p) || -- Reject relative URLs. - isJust (matchRegex slashDotDot p) then - sendError InternalServerError - else - serveStaticFile mimeType fp - where - fp = root p - mimeType = guessMimeType fp - _ -> - sendError InternalServerError +staticHandler :: String -> String -> HttpT IO () +staticHandler root p = do + logMessage $ "Got request for static content: " ++ p + if dotDotSlash `isInfixOf` p || -- Reject relative URLs. + slashDotDot `isInfixOf` p then + sendError InternalServerError + else + serveStaticFile mimeType fp + where + fp = root p + mimeType = guessMimeType fp -- Handle requests for content. -contentHandler :: State -> [String] -> HttpT IO () -contentHandler (c,mc,ai,s,objects_) gs = do +contentHandler :: State -> String -> HttpT IO () +contentHandler (c,mc,ai,s,objects_) oid = do objects <- lift $ readIORef objects_ -- Current snapshot of object tree. - case gs of - [oid] -> do - logMessage $ printf "Got request for CONTENT for objectId=%s" oid - -- Serve the file which the object maps to. - case findByObjectId oid objects of - Just o -> - serveStaticFile mt fp - where - od = getObjectData o - fp = objectFileName od - mt = objectMimeType od - Nothing -> - sendError NotFound - _ -> - sendError InternalServerError + logMessage $ printf "Got request for CONTENT for objectId=%s" oid + -- Serve the file which the object maps to. + case findByObjectId oid objects of + Just o -> + serveStaticFile mt fp + where + od = getObjectData o + fp = objectFileName od + mt = objectMimeType od + Nothing -> + sendError NotFound -- Handle requests for device CONTROL urls. -serviceControlHandler :: State -> DeviceType -> [String] -> HttpT IO () -serviceControlHandler (c,mc,ai,s,objects_) deviceType gs = do +serviceControlHandler :: State -> DeviceType -> String -> HttpT IO () +serviceControlHandler (c,mc,ai,s,objects_) deviceType _ = do objects <- lift $ readIORef objects_ -- Current snapshot of object tree. logMessage $ printf "Got request for CONTROL for service '%s'" $ deviceTypeToString deviceType -- Parse the SOAP request @@ -187,9 +179,7 @@ sendError NotImplemented where handleCDA st a objects = do - xml <- lift $ generateActionResponseXml c st objects a - logMessage $ printf "Response: %s" $ xml - sendXml xml + sendXml $ generateActionResponseXml c st objects a handleCMA _ = -- TODO: This should really be implemented as it is required by -- the specification. However, the PS3 doesn't seem to use it at @@ -212,10 +202,12 @@ addHeader (Header HdrConnection "close") -- Send generated XML. -sendXml :: (Monad m, MonadIO m, Functor m) => String -> HttpT m () +sendXml :: (MonadIO m, Functor m) => ByteString -> HttpT m () sendXml xml = do setResponseCode OK - setContentLength $ Just $ toEnum $ length xml + setContentLength $ Just $ toInteger $ L.length xml addHeader (Header HdrConnection "close") addHeader (Header HdrContentType "text/xml") - writeToBody $ fromString $ xml + -- logMessage $ "Sending XML:" + -- logDataLBS xml + writeToBody xml diff --git a/src/HttpMonad.hs b/src/HttpMonad.hs --- a/src/HttpMonad.hs +++ b/src/HttpMonad.hs @@ -1,3 +1,20 @@ +{- + hums - The Haskell UPnP Server + Copyright (C) 2009-2010 Bardur Arantsson + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +-} module HttpMonad ( HttpT , runHttp , HttpResponseCode(..) @@ -6,9 +23,11 @@ , setContentLength , writeToBody , writeFileToBody + , logDataLBS , logMessage , getRequest - , ifRegex + , ifPrefix + , ifPath ) where import Control.Monad.Trans.Class (MonadTrans(..)) @@ -22,10 +41,13 @@ import Network.StreamSocket() import Network.URI (uriPath) import Data.ByteString (ByteString) -import Data.ByteString.UTF8 (fromString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.List (stripPrefix) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) import SendFile (sendFile) import Text.Printf (printf) -import Text.Regex (matchRegex, mkRegex) -- HTTP response codes. data HttpResponseCode = OK @@ -97,7 +119,7 @@ , rspHeaders = headers , rspBody = "" } -- Output the headers. - lift $ liftIO $ output $ fromString sResponse + lift $ liftIO $ output $ encodeUtf8 $ T.pack sResponse -- We've flushed the headers. modify (\s -> s { hHeadersFlushed = True }) @@ -107,11 +129,11 @@ modify $ \st -> st { hStatusCode = c } -- Write to body. -writeToBody :: (Functor m, MonadIO m, Monad m) => ByteString -> HttpT m () +writeToBody :: (Functor m, MonadIO m, Monad m) => L.ByteString -> HttpT m () writeToBody buf = HttpT $ do output <- lift $ hOutput <$> get unHttp $ flushHeaders - lift $ liftIO $ output buf + lift $ liftIO $ output $ S.concat $ L.toChunks buf -- FIXME: Maybe change "output" to use lazy? -- Write the contents of a file to body. writeFileToBody :: (Functor m, MonadIO m, Monad m) => FilePath -> Integer -> Integer -> HttpT m () @@ -124,16 +146,30 @@ logMessage :: (Monad m, MonadIO m) => String -> HttpT m () logMessage s = HttpT $ liftIO $ putStrLn s +logDataLBS :: (Monad m, MonadIO m) => L.ByteString -> HttpT m () +logDataLBS s = HttpT $ liftIO $ L.putStrLn s + -- Get request. getRequest :: (Functor m, Monad m) => HttpT m (Request String) getRequest = HttpT $ ask --- Match request prefix. -ifRegex :: (Functor m, Monad m) => String -> ([String] -> HttpT m ()) -> HttpT m () -> HttpT m () -ifRegex r ifMatch ifNoMatch = do +-- Dispatch based on a test-and-forward function. +dispatchOn :: (Functor m, Monad m) => (String -> Maybe a) -> (a -> HttpT m ()) -> HttpT m () -> HttpT m () +dispatchOn p ifMatch ifNoMatch = do request <- getRequest - case matchRegex re $ urlDecode $ uriPath $ rqURI request of - Just gs -> ifMatch gs + case p $ urlDecode $ uriPath $ rqURI request of + Just r -> ifMatch r Nothing -> ifNoMatch + +-- Match request prefix. The request path is stripped of the prefix +-- before being forwarded to the handler. +ifPrefix :: (Functor m, Monad m) => String -> (String -> HttpT m ()) -> HttpT m () -> HttpT m () +ifPrefix p = dispatchOn (stripPrefix p) + +-- Match full request path. +ifPath :: (Functor m, Monad m) => String -> HttpT m () -> HttpT m () -> HttpT m () +ifPath p ifMatch ifNoMatch = + dispatchOn predicate ifMatch' ifNoMatch where - re = mkRegex r + predicate p' = if p == p' then Just () else Nothing + ifMatch' _ = ifMatch diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -34,7 +34,7 @@ import Paths_hums import Data.IORef import Handlers -import HttpMonad (ifRegex) +import HttpMonad (ifPath, ifPrefix) defaultMediaServerConfiguration :: String -> MediaServerConfiguration defaultMediaServerConfiguration uuid_ = @@ -88,11 +88,11 @@ let st = (c,mc,appInfo,services, defaultObjects) let handlers = - ifRegex "^/description\\.xml$" (rootDescriptionHandler st) $ - ifRegex "^/static/(.*)$" (staticHandler $ dataDirectory "www") $ - ifRegex "^/dynamic/services/ContentDirectory/control/?$" (serviceControlHandler st ContentDirectoryDevice) $ - ifRegex "^/dynamic/services/ConnectionManager/control/?$" (serviceControlHandler st ConnectionManagerDevice) $ - ifRegex "^/content/([0-9a-f,]+)$" (contentHandler st) $ + ifPath "/description.xml" (rootDescriptionHandler st) $ + ifPrefix "/static/" (staticHandler $ dataDirectory "www") $ + ifPrefix "/dynamic/services/ContentDirectory/control" (serviceControlHandler st ContentDirectoryDevice) $ + ifPrefix "/dynamic/services/ConnectionManager/control" (serviceControlHandler st ConnectionManagerDevice) $ + ifPrefix "/content/" (contentHandler st) $ fallbackHandler -- Start serving. diff --git a/src/Object.hs b/src/Object.hs --- a/src/Object.hs +++ b/src/Object.hs @@ -32,8 +32,8 @@ import Action import Data.Char (isAscii) -import Data.Map (Map) -import qualified Data.Map as Map +import Data.HashMap (HashMap) +import qualified Data.HashMap as H import Data.List (isPrefixOf) import DirectoryUtils import System.FilePath @@ -61,8 +61,8 @@ -- An Objects is an abstract data type containing a set of -- objects. data Objects = Objects - { mapIdToObject :: Map ObjectId Object - , mapParentToChildren :: Map ObjectId [ObjectId] + { mapIdToObject :: HashMap ObjectId Object + , mapParentToChildren :: HashMap ObjectId [ObjectId] , systemUpdateId :: Int64 } deriving (Show) @@ -109,7 +109,7 @@ -- Get the children object of a given object. getChildren :: Objects -> ObjectId -> [(ObjectId,Object)] getChildren os pid = - case Map.lookup pid $ mapParentToChildren os of + case H.lookup pid $ mapParentToChildren os of Just cs -> map (\oid -> (oid, findExistingByObjectId oid os)) cs Nothing -> [] @@ -120,7 +120,7 @@ -- Find object by object ID. findByObjectId :: ObjectId -> Objects -> Maybe Object -findByObjectId oid = Map.lookup oid . mapIdToObject +findByObjectId oid = H.lookup oid . mapIdToObject -- Find object which is known to exist by object ID. findExistingByObjectId :: ObjectId -> Objects -> Object @@ -174,15 +174,11 @@ objects <- walkTree [] scanFile d -- Add the special top-level root item. let o' = (rootObject : objects) - -- Construct a map from parents to children. - let mapParentToChildrenX = foldl p2c Map.empty o' - - let getModificationTime = objectLastModified . getObjectData . snd - + -- Construct the objects map. return Objects - { mapIdToObject = Map.fromList o' - , mapParentToChildren = mapParentToChildrenX - , systemUpdateId = maximum $ map getModificationTime o' + { mapIdToObject = H.fromList o' + , mapParentToChildren = foldl p2c H.empty o' + , systemUpdateId = maximum $ map (objectLastModified . getObjectData . snd) o' } where -- The root object is fixed. @@ -196,8 +192,8 @@ , objectMimeType = "inode/directory" })) p2c acc (oid, o) = - Map.alter (\x -> case x of - Nothing -> Just [oid] - Just cs -> Just (oid:cs)) pid acc + H.alter (\x -> case x of + Nothing -> Just [oid] + Just cs -> Just (oid:cs)) pid acc where pid = objectParentId $ getObjectData o diff --git a/src/Service.hs b/src/Service.hs --- a/src/Service.hs +++ b/src/Service.hs @@ -22,8 +22,9 @@ , deviceTypeToString ) where -import Text.XML.HXT.Core import Text.Printf +import Text.XML.HaXml.Types +import Text.XML.HaXml.ByteStringPP import Configuration import Action import Data.Maybe (mapMaybe) @@ -33,14 +34,18 @@ import Data.Int import MimeType import URIExtra +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import Data.Text.Lazy.Encoding (decodeUtf8) +import Data.ByteString.Lazy (ByteString) -myQuote :: String -> String +myQuote :: Text -> Text myQuote = -- TODO: There *must* be a better way to achieve our quoting needs. - concatMap f + T.concatMap f where - f '<' = "<" - f '>' = ">" - f c = [c] + f '<' = T.pack "<" + f '>' = T.pack ">" + f c = T.singleton c sanitizeXmlChars :: String -> String sanitizeXmlChars = map f @@ -50,10 +55,44 @@ f '&' = '_' f c = c -optSelem :: ArrowXml a => String -> Maybe String -> a n XmlTree -optSelem n Nothing = cmt $ printf " %s omitted " n -optSelem n (Just x) = selem n [txt x] +-- +-- Helpers for constructing XML. +-- +comment :: String -> Content () +comment c = CMisc (Comment c) () +simpleElement :: Name -> [Content ()] -> Content () +simpleElement n c = CElem (Elem n [] c) () + +textElement :: Name -> String -> Content () +textElement n t = optTextElement n $ Just t + +emptyElement :: Name -> Content () +emptyElement n = elementToContent $ Elem n [] [] + +text :: String -> Content () +text t = CString False t () + +optTextElement :: String -> Maybe String -> Content () +optTextElement n Nothing = comment $ printf " %s omitted" n +optTextElement n (Just t) = elementToContent $ Elem n [] [text t] + +attribute :: Name -> String -> Attribute +attribute n v = (n, AttValue [Left v]) + +mkDocument :: Element () -> Document () +mkDocument rootElement = + (Document _prolog emptyST rootElement []) + where + _prolog = Prolog xmlDecl [] Nothing [] + xmlDecl = Just $ XMLDecl xmlVers encDecl Nothing + encDecl = Just $ EncodingDecl "utf-8" + xmlVers = "1.0" + +elementToContent :: Element () -> Content () +elementToContent e = CElem e () + +-- Device types. data DeviceType = MediaServer | ContentDirectoryDevice | ConnectionManagerDevice @@ -63,220 +102,202 @@ deviceTypeToString ConnectionManagerDevice = "ConnectionManager" deviceTypeToString MediaServer = "MediaServer" -serviceNs :: ArrowXml a => String -> DeviceType -> a XmlTree XmlTree -serviceNs prefix st = - sattr an av - where - an = printf "xmlns:%s" prefix - av = printf "urn:schemas-upnp-org:service:%s:1" $ deviceTypeToString st +serviceNs :: String -> DeviceType -> Attribute +serviceNs prefix st = attribute an av + where + an = printf "xmlns:%s" prefix + av = printf "urn:schemas-upnp-org:service:%s:1" $ deviceTypeToString st serviceNs' :: DeviceType -> String serviceNs' = printf "urn:schemas-upnp-org:service:%s:1" . deviceTypeToString -- Generate the icon list. -generateIconList :: ArrowXml a => Bool -> a XmlTree XmlTree -generateIconList False = cmt " omitted device icon list " +generateIconList :: Bool -> Content () +generateIconList False = comment " omitted device icon list " generateIconList True = - selem "iconList" - [ selem "icon" - [ selem "mimetype" [ txt $ guessMimeType imageUrl ] - , selem "width" [ txt "240" ] - , selem "height" [ txt "240" ] - , selem "url" [ txt imageUrl ] - ] - ] + (simpleElement "iconList" + [ simpleElement "icon" + [ textElement "mimetype" $ guessMimeType imageUrl + , textElement "width" "240" + , textElement "height" "240" + , textElement "url" imageUrl + ] + ]) where imageUrl = "/static/images/hums.jpg" -generateServiceList :: ArrowXml a => [DeviceType] -> a XmlTree XmlTree +generateServiceList :: [DeviceType] -> Content () generateServiceList services = - selem "serviceList" $ map generateService services + simpleElement "serviceList" $ map generateService services where generateService service = - selem "service" - [ selem "serviceType" [txt $ serviceNs' service] - , selem "serviceId" [txt $ printf "urn:upnp-org:serviceId:%s" dt] - , selem "SCPDURL" [txt $ printf "/static/services/%s/description.xml" dt] - , selem "controlURL" [txt $ printf "/dynamic/services/%s/control/" dt] - , selem "eventSubURL" [txt $ printf "/dynamic/services/%s/event/" dt] - ] + ( simpleElement "service" + [ textElement "serviceType" $ serviceNs' service + , textElement "serviceId" $ printf "urn:upnp-org:serviceId:%s" dt + , textElement "SCPDURL" $ printf "/static/services/%s/description.xml" dt + , textElement "controlURL" $ printf "/dynamic/services/%s/control/" dt + , textElement "eventSubURL" $ printf "/dynamic/services/%s/event/" dt + ] ) where dt = deviceTypeToString service -generateDescription :: ArrowXml a => Configuration -> MediaServerConfiguration -> [DeviceType] -> a XmlTree XmlTree +generateDescription :: Configuration -> MediaServerConfiguration -> [DeviceType] -> Document () generateDescription c mc services = - root [] - [ mkelem "root" [sattr "xmlns" "urn:schemas-upnp-org:device-1-0"] - [ selem "specVersion" - [ selem "major" [ txt "1" ] - , selem "minor" [ txt "0" ] - ] - , selem "URLBase" [ txt $ show $ httpServerBase c ] - , selem "device" - [ selem "UDN" [ txt $ printf "uuid:%s" $ uuid mc ] - , selem "friendlyName" [ txt $ friendlyName mc ] - , selem "manufacturer" [ txt $ manufacturer mc ] - , selem "manufacturerURL" [ txt $ manufacturerUrl mc ] - , optSelem "modelDescription" $ modelDescription mc - , selem "modelName" [ txt $ modelName mc ] - , selem "modelNumber" [ txt $ modelNumber mc ] - , selem "modelURL" [ txt $ modelUrl mc ] - , optSelem "serialNumber" $ serialNumber mc - , selem "deviceType" [ txt $ printf "urn:schemas-upnp-org:device:%s:1" deviceType ] - , optSelem "UPC" $ upc mc --- , optSelemNs "dlna:X_DNLADOC" [sattr "xmlns" "urn:schemas-dlna-org:device-1-0"] $ dlna - , generateIconList $ enableDeviceIcon c - , generateServiceList services - , selem "presentationURL" [ txt presentationUrl ] - ] - ] - ] + (mkDocument + (Elem "root" [attribute "xmlns" "urn:schemas-upnp-org:device-1-0"] + [ simpleElement "specVersion" + [ textElement "major" "1" + , textElement "minor" "0" + ] + , textElement "URLBase" $ show $ httpServerBase c + , simpleElement "device" + [ textElement "UDN" $ printf "uuid:%s" $ uuid mc + , textElement "friendlyName" $ friendlyName mc + , textElement "manufacturer" $ manufacturer mc + , textElement "manufacturerURL" $ manufacturerUrl mc + , optTextElement "modelDescription" $ modelDescription mc + , textElement "modelName" $ modelName mc + , textElement "modelNumber" $ modelNumber mc + , textElement "modelURL" $ modelUrl mc + , optTextElement "serialNumber" $ serialNumber mc + , textElement "deviceType" $ printf "urn:schemas-upnp-org:device:%s:1" deviceType + , optTextElement "UPC" $ upc mc +-- , optSelemNs "dlna:X_DNLADOC" [sattr "xmlns" "urn:schemas-dlna-org:device-1-0"] $ dlna + , generateIconList $ enableDeviceIcon c + , generateServiceList services + , textElement "presentationURL" "index.html" + ] + ])) where deviceType = deviceTypeToString MediaServer -- dlna = if useDlna mc then (Just "DMS-1.00") else Nothing - presentationUrl = "index.html" --- Transform an XmlTree to a string. -generateXml :: SysConfigList -> IOSLA (XIOState ()) XmlTree XmlTree -> IO String -generateXml conf a = do - xml <- runX (a >>> writeDocumentToString (withOutputEncoding utf8 : conf)) - return $ concat xml - -generateDescriptionXml :: Configuration -> MediaServerConfiguration -> [DeviceType] -> IO String -generateDescriptionXml c mc = - generateXml [] . generateDescription c mc - - -generateResponseXml :: [IOSLA (XIOState ()) XmlTree XmlTree] -> IO String -generateResponseXml = - generateXml [ withOutputPLAIN ] . generateSoapEnvelope - -generateBrowseResponseXml :: Configuration -> DeviceType -> Objects -> BrowseAction -> IO String - -generateBrowseResponseXml cfg st os (BrowseMetadata bps) = do - didlXml <- fmap myQuote $ generateXml [] didl - let body = [ mkelem "u:BrowseResponse" [ serviceNs "u" st ] - [ selem "Result" [ txt didlXml ] - , selem "NumberReturned" [ txt "1" ] -- CD/§2.7.4.2 - , selem "TotalMatches" [ txt "1" ] -- CD/§2.7.4.2 - , selem "UpdateID" [ txt $ printf "%d" $ systemUpdateId os ] - ] - ] - generateResponseXml body +mkBrowseResponse :: Integral a => Configuration -> DeviceType -> Objects -> a -> a -> Element () -> Element () +mkBrowseResponse cfg st os numberReturned totalMatches didl = + ( Elem "u:BrowseResponse" [ serviceNs "u" st ] + [ textElement "Result" didlXml + , textElement "NumberReturned" $ show numberReturned -- CD/§2.7.4.2 + , textElement "TotalMatches" $ show totalMatches -- CD/§2.7.4.2 + , textElement "UpdateID" $ printf "%d" $ systemUpdateId os + ] ) where - didl = mkDidl [generateObjectElement cfg os (oid,o)] - oid = objectId bps - o = findExistingByObjectId oid os -- TODO: Might handle non-existing objects better. + didlXml = T.unpack $ myQuote $ decodeUtf8 $ element $ didl +generateBrowseResponse :: Configuration -> DeviceType -> Objects -> BrowseAction -> Element () +generateBrowseResponse cfg st os (BrowseMetadata bps) = + mkBrowseResponse cfg st os n n didl + where + n = 1 :: Int + didl = mkDidl [generateObjectElement cfg os (oid,o)] + oid = objectId bps + o = findExistingByObjectId oid os -- TODO: Might handle non-existing objects better. -generateBrowseResponseXml cfg st os (BrowseDirectChildren bps) = do - didlXml <- fmap myQuote $ generateXml [] didl - let body = [ mkelem "u:BrowseResponse" [ serviceNs "u" st ] - [ selem "Result" [ txt didlXml ] - , selem "NumberReturned" [ txt numberReturned ] - , selem "TotalMatches" [ txt totalMatches ] - , selem "UpdateID" [ txt $ printf "%d" $ systemUpdateId os ] - ] - ] - generateResponseXml body +generateBrowseResponse cfg st os (BrowseDirectChildren bps) = + mkBrowseResponse cfg st os numberReturned totalMatches didl where oid = objectId bps si = startingIndex bps rc = requestedCount bps - totalMatches = show $ getNumberOfChildren os oid -- CD/§2.7.4.2 - numberReturned = show $ length chosenChildren + totalMatches = getNumberOfChildren os oid -- CD/§2.7.4.2 + numberReturned = length chosenChildren slicer = if rc<=0 then id else slice si rc -- CD/§2.7.4.2 chosenChildren = slicer $ Object.getChildren os oid didl = mkDidl $ map (generateObjectElement cfg os) chosenChildren -generateActionResponseXml :: Configuration -> DeviceType -> Objects -> ContentDirectoryAction -> IO String +generateDescriptionXml :: Configuration -> MediaServerConfiguration -> [DeviceType] -> ByteString +generateDescriptionXml c mc = document . generateDescription c mc +generateResponseXml :: Element () -> ByteString +generateResponseXml d = document $ generateSoapEnvelope d + +generateBrowseResponseXml :: Configuration -> DeviceType -> Objects -> BrowseAction -> ByteString +generateBrowseResponseXml cfg st os action = generateResponseXml $ generateBrowseResponse cfg st os action + +generateActionResponseXml :: Configuration -> DeviceType -> Objects -> ContentDirectoryAction -> ByteString + generateActionResponseXml _ st os ContentDirectoryGetSystemUpdateId = - generateXml [] $ generateSoapEnvelope body + generateResponseXml body where - body = [ mkelem "u:GetSystemUpdateIDResponse" [ serviceNs "u" st ] - [ selem "Id" [ txt $ show $ systemUpdateId os ] ] ] + body = ( Elem "u:GetSystemUpdateIDResponse" [ serviceNs "u" st ] + [ textElement "Id" $ show $ systemUpdateId os ] ) generateActionResponseXml cfg st os (ContentDirectoryBrowse ba) = generateBrowseResponseXml cfg st os ba generateActionResponseXml _ st _ ContentDirectoryGetSearchCapabilities = - generateXml [] $ generateSoapEnvelope body + generateResponseXml body where - body = [ mkelem "u:GetSearchCapabilitiesResponse" [ serviceNs "u" st ] - [ selem "SearchCaps" [ txt "" ] ] -- No search capabilities (CD/§2.5.18) - ] + body = ( Elem "u:GetSearchCapabilitiesResponse" [ serviceNs "u" st ] + [ emptyElement "SearchCaps" ] -- No search capabilities (CD/§2.5.18) + ) generateActionResponseXml _ st _ ContentDirectoryGetSortCapabilities = - generateXml [] $ generateSoapEnvelope body + generateResponseXml body where - body = [ mkelem "u:GetSortCapabilitiesResponse" [ serviceNs "u" st ] - [ selem "SortCaps" [ txt "" ] ] -- No sorting capabilities (CD/§2.5.19) - ] + body = ( Elem "u:GetSortCapabilitiesResponse" [ serviceNs "u" st ] + [ emptyElement "SortCaps" ] -- No sorting capabilities (CD/§2.5.19) + ) -generateSoapEnvelope :: ArrowXml a => [a XmlTree XmlTree] -> a XmlTree XmlTree -generateSoapEnvelope b = - root [] - [ mkelem "s:Envelope" [ soapNs, soapEncodingStyle ] - [ selem "s:Body" b ] - ] +generateSoapEnvelope :: Element () -> Document () +generateSoapEnvelope bodyE = + ( mkDocument + ( Elem "s:Envelope" [ soapNs, soapEncodingStyle ] + [ simpleElement "s:Body" [elementToContent bodyE] ] + ) + ) where - soapNs = sattr "xmlns:s" $ printf "%s/envelope/" urlPrefix - soapEncodingStyle = sattr "s:encodingStyle" $ printf "%s/encoding/" urlPrefix + soapNs = attribute "xmlns:s" $ printf "%s/envelope/" urlPrefix + soapEncodingStyle = attribute "s:encodingStyle" $ printf "%s/encoding/" urlPrefix urlPrefix = "http://schemas.xmlsoap.org/soap" -generateObjectElement :: ArrowXml a => Configuration -> Objects -> (ObjectId, Object) -> a XmlTree XmlTree +generateObjectElement :: Configuration -> Objects -> (ObjectId, Object) -> Element () generateObjectElement cfg objects (oid, o) = - mkelem en (as ++ eas) - ([ selem "dc:title" [ txt $ sanitizeXmlChars $ objectTitle od ] - , selem "upnp:class" [ txt $ getObjectClassName o ] - ] ++ ee) + ( Elem en (as ++ eas) + ( [ textElement "dc:title" $ sanitizeXmlChars $ objectTitle od + , textElement "upnp:class" $ getObjectClassName o + ] ++ (map elementToContent ee) + ) + ) where od = getObjectData o en = getObjectElementName o ee = generateExtraElements cfg (oid,o) - as = [ sattr "id" oid - , sattr "parentID" $ objectParentId od + as = [ attribute "id" oid + , attribute "parentID" $ objectParentId od ] eas = generateExtraAttributes objects (oid,o) -- Generate any attributes required for any given object. -- (Apart from the attributes of the 'object' class itself.) -generateExtraAttributes :: ArrowXml a => Objects -> (ObjectId, Object) -> [a XmlTree XmlTree] +generateExtraAttributes :: Objects -> (ObjectId, Object) -> [Attribute] generateExtraAttributes objects (oid, (Container,_)) = genContainerAttributes objects oid generateExtraAttributes objects (oid, (ContainerStorageFolder,_)) = genContainerAttributes objects oid generateExtraAttributes _ (_, (ItemMusicTrack,_)) = genItemAttributes generateExtraAttributes _ (_, (ItemVideoMovie,_)) = genItemAttributes -- Generate content URL -generateContentUrl :: ArrowXml a => Configuration -> ObjectId -> a XmlTree XmlTree -generateContentUrl cfg oid = - txt $ show $ mkURI ["content", oid] $ httpServerBase cfg -- Generate any extra elements for any given object. -generateExtraElements :: ArrowXml a => Configuration -> (ObjectId, Object) -> [a XmlTree XmlTree] +generateExtraElements :: Configuration -> (ObjectId, Object) -> [Element ()] generateExtraElements _ (oid, (Container,_)) = [] generateExtraElements _ (oid, (ContainerStorageFolder,_)) = [] -generateExtraElements cfg (oid, (ItemMusicTrack,d)) = - [ mkelem "res" [ sattr "protocolInfo" protocolInfo - , sattr "size" $ printf "%d" $ objectFileSize d ] -- TODO: should be disabled by Transcoding flag! - [ generateContentUrl cfg oid ] - ] - where - mimeType = objectMimeType d - protocolInfo = generateProtocolInfo cfg False mimeType Nothing -- TODO: profileId +generateExtraElements cfg (oid, (ItemMusicTrack,d)) = generateExtraElementsForFile cfg oid d +generateExtraElements cfg (oid, (ItemVideoMovie,d)) = generateExtraElementsForFile cfg oid d -generateExtraElements cfg (oid, (ItemVideoMovie,d)) = - [ mkelem "res" [ sattr "protocolInfo" protocolInfo - , sattr "size" $ printf "%d" $ objectFileSize d ] -- TODO: should be disabled by Transcoding flag! - [ generateContentUrl cfg oid ] - ] +generateExtraElementsForFile :: Configuration -> ObjectId -> ObjectData -> [Element ()] +generateExtraElementsForFile cfg oid d = + [ Elem "res" + [ attribute "protocolInfo" protocolInfo + , attribute "size" $ printf "%d" $ objectFileSize d ] -- TODO: should be disabled by Transcoding flag! + [ contentUrl ] + ] where mimeType = objectMimeType d protocolInfo = generateProtocolInfo cfg False mimeType Nothing -- TODO: profileId + contentUrl = text $ show $ mkURI ["content", oid] $ httpServerBase cfg mapMaybe1 :: (a -> b) -> Maybe a -> Maybe b mapMaybe1 f Nothing = Nothing @@ -326,29 +347,26 @@ -- Gnerate extra attributes for containers. -genContainerAttributes :: ArrowXml a => Objects -> ObjectId -> [a XmlTree XmlTree] +genContainerAttributes :: Objects -> ObjectId -> [Attribute] genContainerAttributes objects oid = - [ sattr "searchable" "0" - , sattr "restricted" "0" - , sattr "childCount" $ show $ getNumberOfChildren objects oid + [ attribute "searchable" "0" + , attribute "restricted" "0" + , attribute "childCount" $ show $ getNumberOfChildren objects oid ] -- Generate extra attributes for items. -genItemAttributes :: ArrowXml a => [a XmlTree XmlTree] +genItemAttributes :: [Attribute] genItemAttributes = [] -- Create the DIDL result object. -mkDidl :: ArrowXml a => [a XmlTree XmlTree] -> a XmlTree XmlTree +mkDidl :: [Element ()] -> Element () mkDidl es = - selem "dummy" -- Not using 'root' means we avoid the XML declaration - [ mkelem "DIDL-Lite" [ sattr "xmlns:dc" dcNs - , sattr "xmlns:upnp" upnpNs - , sattr "xmlns" ns ] - es ] - where - dcNs = "http://purl.org/dc/elements/1.1/" - upnpNs = "urn:schemas-upnp-org:metadata-1-0/upnp/" - ns = "urn:schemas-upnp-org:metadata-1-0/DIDL-Lite/" + ( Elem "DIDL-Lite" + [ attribute "xmlns:dc" "http://purl.org/dc/elements/1.1/" + , attribute "xmlns:upnp" "urn:schemas-upnp-org:metadata-1-0/upnp/" + , attribute "xmlns" "urn:schemas-upnp-org:metadata-1-0/DIDL-Lite/" ] + ( map elementToContent es ) + ) -- Slice out a portion of a list. diff --git a/src/Soap.hs b/src/Soap.hs --- a/src/Soap.hs +++ b/src/Soap.hs @@ -151,5 +151,4 @@ conf :: SysConfigList conf = [ withValidate no , withCheckNamespaces False - , withTrace 3 ]