hums 0.3.1 → 0.3.2
raw patch · 8 files changed
+332/−328 lines, 8 filesdep +HaXmldep +hashmapdep +textdep −network-bytestringdep −regex-compatdep −utf8-stringdep ~HTTPdep ~hxtdep ~mtl
Dependencies added: HaXml, hashmap, text
Dependencies removed: network-bytestring, regex-compat, utf8-string
Dependency ranges changed: HTTP, hxt, mtl, network, uuid
Files
- hums.cabal +41/−43
- src/Didl.hs +0/−35
- src/Handlers.hs +42/−50
- src/HttpMonad.hs +48/−12
- src/Main.hs +6/−6
- src/Object.hs +13/−17
- src/Service.hs +182/−164
- src/Soap.hs +0/−1
hums.cabal view
@@ -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 <bardur@scientician.net>-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
− src/Didl.hs
@@ -1,35 +0,0 @@-{-- hums - The Haskell UPnP Server- Copyright (C) 2009 Bardur Arantsson <bardur@scientician.net>-- 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 <http://www.gnu.org/licenses/>.--}--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/"
src/Handlers.hs view
@@ -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
src/HttpMonad.hs view
@@ -1,3 +1,20 @@+{-+ hums - The Haskell UPnP Server+ Copyright (C) 2009-2010 Bardur Arantsson <bardur@scientician.net>++ 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 <http://www.gnu.org/licenses/>.+-} 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
src/Main.hs view
@@ -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.
src/Object.hs view
@@ -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
src/Service.hs view
@@ -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.
src/Soap.hs view
@@ -151,5 +151,4 @@ conf :: SysConfigList conf = [ withValidate no , withCheckNamespaces False- , withTrace 3 ]