hums 0.2.4 → 0.2.5
raw patch · 14 files changed
+163/−177 lines, 14 filesdep ~HTTPdep ~hxtdep ~sendfile
Dependency ranges changed: HTTP, hxt, sendfile
Files
- hums.cabal +6/−4
- src/Action.hs +4/−4
- src/Configuration.hs +11/−11
- src/Didl.hs +5/−5
- src/DirectoryUtils.hs +5/−10
- src/HttpExtra.hs +4/−5
- src/HttpServer.hs +8/−11
- src/Main.hs +39/−40
- src/Object.hs +15/−15
- src/RegexExtra.hs +1/−1
- src/Service.hs +55/−60
- src/SimpleServiceDiscoveryProtocol.hs +5/−5
- src/StorableExtra.hs +4/−5
- src/URIExtra.hs +1/−1
hums.cabal view
@@ -1,7 +1,9 @@ Name: hums-Version: 0.2.4+Version: 0.2.5 Synopsis: Haskell UPnP Media Server Description: A simple UPnP Media Server.+ .+ Currently this has only been tested with a PlayStation 3 client. Any help/patches for getting it to work with other clients would be much appreciated. License: GPL License-file: COPYING.txt Category: Network@@ -12,7 +14,7 @@ Build-Depends: base >= 3 && <4, haskell98, network >= 2.2.0.1,- HTTP >= 4000.0.7,+ HTTP >= 4000.0.8, filepath >= 1.1.0.0, parsec >= 2.1.0.0 && < 3.0, regex-compat >= 0.91,@@ -22,10 +24,10 @@ uuid >= 1.0.0, bytestring >= 0.9.0.1, MissingH >= 1.0.1,- hxt >= 8.3.1,+ hxt >= 8.3.1 && < 8.4, ConfigFile >= 1.0.5, mtl >= 1.1.0.2,- sendfile >= 0.5+ sendfile >= 0.6.1 && < 0.7 data-dir: data data-files: hums.cfg www/images/hums.jpg
src/Action.hs view
@@ -28,10 +28,10 @@ data BrowseParameters = BrowseParameters { objectId :: ObjectId- , browse_filter :: String- , starting_index :: Int- , requested_count :: Int- , sort_criteria :: String+ , browseFilter :: String+ , startingIndex :: Int+ , requestedCount :: Int+ , sortCriteria :: String } deriving (Show)
src/Configuration.hs view
@@ -40,9 +40,9 @@ -} data Configuration = - Configuration { local_net_ip :: String+ Configuration { localNetIp :: String , httpServerBase :: URI- , http_server_port :: Word16+ , httpServerPort :: Word16 , enableDeviceIcon :: Bool , useDlna :: Bool , dlnaProfileName :: Maybe String -- Only used when useDlna is available.@@ -86,7 +86,7 @@ getApplicationInformation :: IO ApplicationInformation getApplicationInformation = do systemId <- getSystemID- return $ ApplicationInformation + return ApplicationInformation { operatingSystemName = systemName systemId , operatingSystemVersion = release systemId , applicationName = "hums"@@ -104,14 +104,14 @@ ip <- get cf networkSection "listen_ip" port <- get cf networkSection "listen_port" rootDirectory_ <- get cf defaultSection "root_directory"- return $ Configuration - { local_net_ip = ip- , http_server_port = port- , httpServerBase = fromJust $ parseURI $ "http://" ++ ip ++ ":" ++ (show port)- , enableDeviceIcon = True- , useDlna = True- , dlnaProfileName = Nothing- , rootDirectory = rootDirectory_ }+ return Configuration + { localNetIp = ip+ , httpServerPort = port+ , httpServerBase = fromJust $ parseURI $ printf "http://%s:%d" ip port+ , enableDeviceIcon = True+ , useDlna = True+ , dlnaProfileName = Nothing+ , rootDirectory = rootDirectory_ } return $ forceEither cfg where defaultSection = "DEFAULT"
src/Didl.hs view
@@ -24,11 +24,11 @@ -- 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 ])+ 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/"
src/DirectoryUtils.hs view
@@ -40,21 +40,16 @@ let names = sort $ filter (not . isSpecialDirectory) allNames -- Produce full names. let fullNames = map (combine d) names- -- Traverse subdirectories.- s' <- foldM traverse s0 fullNames- -- Return the accumulator.- return s'-+ -- Traverse subdirectories and return accumulator.+ foldM traverse s0 fullNames where traverse s n = do isDirectory <- doesDirectoryExist n if isDirectory then do s' <- f s0 s n- s'' <- walkTree s' f n- return s''- else do- s' <- f s0 s n- return s'+ walkTree s' f n+ else+ f s0 s n isSpecialDirectory ".." = True isSpecialDirectory "." = True
src/HttpExtra.hs view
@@ -22,7 +22,7 @@ import Text.ParserCombinators.Parsec parseRange :: GenParser Char a (Maybe Integer, Maybe Integer)-parseRange = do+parseRange = choice [parseFullRange, parseEndRange, parseSingleByteRange]@@ -44,18 +44,17 @@ parseSingleByteRange = do i1 <- parseInteger char '-'- return (Just $ i1, Just $ i1)+ return (Just i1, Just i1) parseInteger :: GenParser Char a Integer parseInteger = do ds <- many1 digit- return $ ((read ds) :: Integer)+ return (read ds :: Integer) parseRanges :: GenParser Char a [(Maybe Integer, Maybe Integer)] parseRanges = do string "bytes="- rs <- parseRange `sepBy` (char ',')- return rs+ parseRange `sepBy` char ',' parseRangeHeader :: String -> [(Maybe Integer, Maybe Integer)] parseRangeHeader s =
src/HttpServer.hs view
@@ -52,7 +52,7 @@ runHttpServer' :: RequestHandler -> Word16 -> IO () runHttpServer' r p = do- let p' = (fromIntegral p) :: PortNumber+ let p' = fromIntegral p :: PortNumber let sa = SockAddrInet p' iNADDR_ANY s <- socket AF_INET Stream 0 setSocketOption s ReuseAddr 1@@ -74,9 +74,7 @@ result <- receiveHTTP c case result of Left _ -> error "Error reading request"- Right req -> do- -- Got the request, now let's invoke the request handler.- r c req+ Right req -> r c req sendHeaders :: Socket -> ResponseCode -> String -> [Header] -> IO ()@@ -98,15 +96,14 @@ myRequestHandler :: [(Regex, UrlHandler)] -> Socket -> Request String -> IO ()-myRequestHandler hs s r = do+myRequestHandler hs s r = case dispatch hs (urlDecode $ uriPath $ rqURI r) of Nothing -> sendErrorResponse s InternalServerError [] Just (h,gs) -> h s r gs runHttpServer :: [(Regex, UrlHandler)] -> Word16 -> IO ()-runHttpServer hs p = do- runHttpServer' (myRequestHandler hs) p+runHttpServer = runHttpServer' . myRequestHandler {- @@ -114,13 +111,13 @@ -} -sendOkHeaders :: Socket -> [Header] -> Int -> IO ()+sendOkHeaders :: Socket -> [Header] -> Integer -> IO () sendOkHeaders conn hs contentLength = let h1 = Header HdrContentLength $ printf "%d" contentLength in let h2 = Header HdrConnection "close" in sendHeaders conn (2,0,0) "OK" (h1 : h2 : hs) -sendPartialContentHeaders :: Socket -> [Header] -> (Integer,Integer) -> Int -> IO ()+sendPartialContentHeaders :: Socket -> [Header] -> (Integer,Integer) -> Integer -> IO () sendPartialContentHeaders conn hs (rLow,rHigh) entitySize = let h1 = Header HdrContentLength $ printf "%d" (rHigh-rLow+1) in let h2 = Header HdrContentRange $ printf "%d-%d/%d" rLow rHigh entitySize in@@ -131,7 +128,7 @@ sendXmlResponse :: Socket -> [Header] -> String -> IO () sendXmlResponse conn hs xml = do- sendOkHeaders conn ( (Header HdrContentType "text/xml") : hs ) $ length xml+ sendOkHeaders conn ( Header HdrContentType "text/xml" : hs ) $ toEnum $ length xml sendBody conn xml @@ -144,7 +141,7 @@ sendErrorResponse :: Socket -> HttpError -> [Header] -> IO ()-sendErrorResponse conn e hs = do+sendErrorResponse conn e hs = sendHeaders conn c r ([ Header HdrContentLength "0" , Header HdrConnection "close"
src/Main.hs view
@@ -30,7 +30,7 @@ import Data.List import Text.Printf import Action-import System.IO (withFile, hFileSize, IOMode(..), Handle)+import System.IO (withFile, hFileSize, IOMode(..)) import qualified Data.UUID as U import qualified Data.UUID.V1 as U1 import MimeType@@ -70,17 +70,17 @@ sendXmlResponse conn (getExtraHeaders ai) xml putStrLn "Send root description." -hCopyBytes :: Handle -> Socket -> Integer -> Integer -> IO ()+hCopyBytes :: FilePath -> Socket -> Integer -> Integer -> IO () hCopyBytes src dst ofs len = do putStrLn $ printf "Sending %d bytes..." len sendFile' dst src ofs len -- Copy a set of ranges between two handles.-hCopyRanges :: Handle -> Socket -> [(Integer,Integer)] -> IO ()-hCopyRanges hnd conn ranges = do+hCopyRanges :: FilePath -> Socket -> [(Integer,Integer)] -> IO ()+hCopyRanges src conn ranges = mapM_ copyRange ranges where- copyRange (lo, hi) = hCopyBytes hnd conn lo $ fromInteger $ hi - lo + 1+ copyRange (lo, hi) = hCopyBytes src conn lo $ fromInteger $ hi - lo + 1 {- @@ -96,21 +96,23 @@ -} -hCanonicalizeRanges :: Handle -> [(Maybe Integer, Maybe Integer)] -> IO [(Integer,Integer)]-hCanonicalizeRanges hnd ranges = do- mapM f ranges+hCanonicalizeRanges :: Integer -> [(Maybe Integer, Maybe Integer)] -> [(Integer,Integer)]+hCanonicalizeRanges fsz ranges =+ map f ranges where f (lo,hi) = do let lo' = case lo of Just x -> x Nothing -> 0- hi' <- case hi of - Just x -> return x- Nothing -> do- l <- hFileSize hnd- return $ l - 1- return (lo', hi')+ let hi' = case hi of+ Just x -> x+ Nothing -> fsz - 1+ (lo', hi') +fileSize :: FilePath -> IO Integer+fileSize fp = + withFile fp ReadMode $ \h -> hFileSize h+ serveStaticFile :: Socket -> [Header] -> String -> FilePath -> IO () serveStaticFile conn hs mimeType fp = do putStrLn $ printf "Serving file '%s'..." fp@@ -122,25 +124,22 @@ Nothing -> [] -- Whole file -- Serve the ranges.- withFile fp ReadMode $ \h -> - do- rs <- hCanonicalizeRanges h ranges- serveFile h rs-+ fsz <- fileSize fp+ let ranges' = hCanonicalizeRanges fsz ranges+ serveFile fsz ranges' where - ohs = [ Header HdrContentType $ mimeType ]- serveFile h [] = do+ ohs = [ Header HdrContentType mimeType ]+ serveFile :: Integer -> [(Integer,Integer)] -> IO ()+ serveFile fsz [] = do -- No range given (or all ranges were invalid), so we handle regularly.- len <- hFileSize h- sendOkHeaders conn ohs $ fromInteger len- hCopyBytes h conn 0 len- serveFile h [r] = do- fs <- fmap fromInteger $ hFileSize h+ sendOkHeaders conn ohs fsz+ hCopyBytes fp conn 0 fsz+ serveFile fsz [r] = do -- Send headers- sendPartialContentHeaders conn ohs r fs+ sendPartialContentHeaders conn ohs r fsz -- Copy data from ranges into body.- hCopyRanges h conn [r]- serveFile h _ =+ hCopyRanges fp conn [r]+ serveFile _ _ = -- This requires multipart/byteranges, but we don't support that -- as of yet. error "Cannot handle multiple ranges in a single request."@@ -158,8 +157,8 @@ staticHandler root conn req gs = do putStrLn $ "Got request for static content: " ++ show gs case gs of- [p] -> if (isJust $ matchRegex dotDotSlash p) || -- Reject relative URLs.- (isJust $ matchRegex slashDotDot p) then+ [p] -> if isJust (matchRegex dotDotSlash p) || -- Reject relative URLs.+ isJust (matchRegex slashDotDot p) then sendErrorResponse conn InternalServerError [] else serveStaticFile conn (getHeaders req) mimeType fp@@ -203,7 +202,7 @@ objects <- readIORef objects_ -- Current snapshot of object tree. case gs of [sn] -> do- putStrLn $ printf "Got request for CONTROL for service '%s'" $ sn+ putStrLn $ printf "Got request for CONTROL for service '%s'" sn case stringToDeviceType sn of Just dt -> do -- Parse the SOAP request@@ -222,13 +221,13 @@ Nothing -> do putStrLn $ printf "Asked about unknown service '%s'" sn sendErrorResponse conn NotImplemented []- _ -> do+ _ -> -- Mapped to our URL space, but not parseable? sendErrorResponse conn NotFound [] where handleCDA st a objects =- generateActionResponseXml c st objects a >>= return- handleCMA _ = do + 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 -- all so I don't have any way to test an implementation anyway.@@ -238,13 +237,13 @@ fallbackHandler :: Socket -> Request String -> [String] -> IO () fallbackHandler conn r gs = do- putStrLn $ "Fallback handler got request:"- putStrLn $ show r+ putStrLn "Fallback handler got request:"+ print r sendErrorResponse conn InternalServerError [] periodicUpdate :: IORef a -> (IO a) -> IO ()-periodicUpdate a doUpdate = do+periodicUpdate a doUpdate = forever $ do threadDelay 120000000 -- Every 120 seconds should be more than enough. writeIORef a =<< doUpdate -- Atomic replace@@ -296,7 +295,7 @@ -- Start serving. putStrLn "Establishing HTTP server..."- forkIO $ runHttpServer dispatchTable $ http_server_port c+ forkIO $ runHttpServer dispatchTable $ httpServerPort c putStrLn "Done." -- Start broadcasting alive messages.@@ -308,6 +307,6 @@ forkIO $ periodicUpdate defaultObjects scanOnce' -- Wait for all threads to terminate.- interact (\p -> p)+ interact id return ()
src/Object.hs view
@@ -118,12 +118,12 @@ -- Get the number of children of a given object. getNumberOfChildren :: Objects -> ObjectId -> Int-getNumberOfChildren os pid =- length $ Object.getChildren os pid -- TODO: Keep track of length instead?+getNumberOfChildren os =+ length . Object.getChildren os -- TODO: Keep track of length instead? -- Find object by object ID. findByObjectId :: ObjectId -> Objects -> Maybe Object-findByObjectId oid os = Map.lookup oid $ mapIdToObject os+findByObjectId oid = Map.lookup oid . mapIdToObject -- Find object which is known to exist by object ID. findExistingByObjectId :: ObjectId -> Objects -> Object@@ -142,7 +142,7 @@ -- Compute object id for the directory entry. -- FIXME: Should handle 'file gone missing' -- simply don't prepend an -- object in that case.- st <- getFileStatus $ fp + st <- getFileStatus fp deviceId <- toHexString $ deviceID st fileId <- toHexString $ fileID st let oid = printf "%s,%s" deviceId fileId@@ -151,11 +151,11 @@ -- Compute file size. let sz = (fromIntegral . System.Posix.fileSize) st -- Compute misc. attributes.- let _title = dropExtension $ takeFileName $ fp+ let _title = dropExtension $ takeFileName fp -- Start by guessing mime type.- let mimeType = case isDirectory st of- True -> "inode/directory" -- Directories are special.- False -> guessMimeType fp+ let mimeType = if isDirectory st then+ "inode/directory" -- Directories are special.+ else guessMimeType fp -- Construct object data. let objectData = MkObjectData kp _title fp sz lastModified mimeType -- Add the directory entry to the current accumulator.@@ -178,7 +178,7 @@ let getModificationTime = objectLastModified . getObjectData . snd - return $ Objects + return Objects { mapIdToObject = Map.fromList o' , mapParentToChildren = mapParentToChildrenX , systemUpdateId = maximum $ map getModificationTime o'@@ -187,12 +187,12 @@ -- The root object is fixed. rootObject = (rootObjectId, - (Container, (MkObjectData { objectParentId = rootObjectParentId- , objectTitle = "root"- , objectFileName = "root"- , objectFileSize = 0- , objectLastModified = 0- , objectMimeType = "inode/directory" })))+ (Container, MkObjectData { objectParentId = rootObjectParentId+ , objectTitle = "root"+ , objectFileName = "root"+ , objectFileSize = 0+ , objectLastModified = 0+ , objectMimeType = "inode/directory" })) p2c acc (oid, o) = Map.alter (\x -> case x of
src/RegexExtra.hs view
@@ -25,7 +25,7 @@ dispatch t s = case findFirst f t of Nothing -> Nothing- Just (v, gs) -> Just $ (v, gs)+ Just (v,gs) -> Just (v, gs) where f (r,v) = case matchRegex r s of Just gs -> Just (v,gs)
src/Service.hs view
@@ -40,7 +40,7 @@ myQuote :: String -> String myQuote = -- TODO: There *must* be a better way to achieve our quoting needs.- concat . map f+ concatMap f where f '<' = "<" f '>' = ">"@@ -61,7 +61,7 @@ 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]+optSelem n (Just x) = selem n [txt x] data DeviceType = MediaServer | ContentDirectoryDevice@@ -85,7 +85,7 @@ av = printf "urn:schemas-upnp-org:service:%s:1" $ deviceTypeToString st serviceNs' :: DeviceType -> String-serviceNs' st = printf "urn:schemas-upnp-org:service:%s:1" $ deviceTypeToString st+serviceNs' = printf "urn:schemas-upnp-org:service:%s:1" . deviceTypeToString -- Generate the icon list. generateIconList :: ArrowXml a => Bool -> a XmlTree XmlTree@@ -96,7 +96,7 @@ [ selem "mimetype" [ txt $ guessMimeType imageUrl ] , selem "width" [ txt "240" ] , selem "height" [ txt "240" ]- , selem "url" [ txt $ imageUrl ]+ , selem "url" [ txt imageUrl ] ] ] where@@ -107,18 +107,18 @@ selem "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]- ])+ 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]+ ] where dt = deviceTypeToString service generateDescription :: ArrowXml a => Configuration -> MediaServerConfiguration -> [DeviceType] -> a XmlTree XmlTree generateDescription c mc services = - (root []+ root [] [ mkelem "root" [sattr "xmlns" "urn:schemas-upnp-org:device-1-0"] [ selem "specVersion" [ selem "major" [ txt "1" ]@@ -135,7 +135,7 @@ , 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 ]+ , 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@@ -143,7 +143,7 @@ , selem "presentationURL" [ txt presentationUrl ] ] ]- ])+ ] where deviceType = deviceTypeToString MediaServer -- dlna = if useDlna mc then (Just "DMS-1.00") else Nothing@@ -152,28 +152,26 @@ -- Transform an XmlTree to a string. generateXml :: Attributes -> IOSLA (XIOState ()) XmlTree XmlTree -> IO String generateXml as a = do- xml <- runX $ (a >>> writeDocumentToString (addEntries as defaultEncodingAttributes))+ xml <- runX (a >>> writeDocumentToString (addEntries as defaultEncodingAttributes)) return $ concat xml generateDescriptionXml :: Configuration -> MediaServerConfiguration -> [DeviceType] -> IO String-generateDescriptionXml c mc services = do- xml <- generateXml [] $ generateDescription c mc services- return xml+generateDescriptionXml c mc =+ generateXml [] . generateDescription c mc generateResponseXml :: [IOSLA (XIOState ()) XmlTree XmlTree] -> IO String-generateResponseXml body = do- xml <- generateXml [(a_output_xml,v_0)] $ generateSoapEnvelope body- return xml+generateResponseXml =+ generateXml [(a_output_xml,v_0)] . 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 "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 ] ] ]@@ -187,45 +185,45 @@ 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 "Result" [ txt didlXml ]+ , selem "NumberReturned" [ txt numberReturned ]+ , selem "TotalMatches" [ txt totalMatches ] , selem "UpdateID" [ txt $ printf "%d" $ systemUpdateId os ] ] ] generateResponseXml body where oid = objectId bps- startIndex = starting_index bps- requestedCount = requested_count bps+ si = startingIndex bps+ rc = requestedCount bps totalMatches = show $ getNumberOfChildren os oid -- CD/§2.7.4.2 numberReturned = show $ length chosenChildren- slicer = if requestedCount<=0 then id else slice startIndex requestedCount -- CD/§2.7.4.2+ 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+ didl = mkDidl $ map (generateObjectElement cfg os) chosenChildren generateActionResponseXml :: Configuration -> DeviceType -> Objects -> ContentDirectoryAction -> IO String -generateActionResponseXml _ st os ContentDirectoryGetSystemUpdateId = do- (generateXml [] $ generateSoapEnvelope body) >>= return+generateActionResponseXml _ st os ContentDirectoryGetSystemUpdateId =+ generateXml [] $ generateSoapEnvelope body where body = [ mkelem "u:GetSystemUpdateIDResponse" [ serviceNs "u" st ] [ selem "Id" [ txt $ show $ systemUpdateId os ] ] ] -generateActionResponseXml cfg st os (ContentDirectoryBrowse ba) = do- generateBrowseResponseXml cfg st os ba >>= return+generateActionResponseXml cfg st os (ContentDirectoryBrowse ba) =+ generateBrowseResponseXml cfg st os ba -generateActionResponseXml _ st _ ContentDirectoryGetSearchCapabilities = do- (generateXml [] $ generateSoapEnvelope body) >>= return+generateActionResponseXml _ st _ ContentDirectoryGetSearchCapabilities =+ generateXml [] $ generateSoapEnvelope body where body = [ mkelem "u:GetSearchCapabilitiesResponse" [ serviceNs "u" st ] [ selem "SearchCaps" [ txt "" ] ] -- No search capabilities (CD/§2.5.18) ] generateActionResponseXml _ st _ ContentDirectoryGetSortCapabilities =- (generateXml [] $ generateSoapEnvelope body) >>= return+ generateXml [] $ generateSoapEnvelope body where body = [ mkelem "u:GetSortCapabilitiesResponse" [ serviceNs "u" st ] [ selem "SortCaps" [ txt "" ] ] -- No sorting capabilities (CD/§2.5.19)@@ -233,10 +231,10 @@ generateSoapEnvelope :: ArrowXml a => [a XmlTree XmlTree] -> a XmlTree XmlTree generateSoapEnvelope b = - (root []- [ mkelem "s:Envelope" [ soapNs, soapEncodingStyle ]- [ selem "s:Body" b ]- ])+ root []+ [ mkelem "s:Envelope" [ soapNs, soapEncodingStyle ]+ [ selem "s:Body" b ]+ ] where soapNs = sattr "xmlns:s" $ printf "%s/envelope/" urlPrefix soapEncodingStyle = sattr "s:encodingStyle" $ printf "%s/encoding/" urlPrefix@@ -245,16 +243,15 @@ generateObjectElement :: ArrowXml a => Configuration -> Objects -> (ObjectId, Object) -> a XmlTree XmlTree generateObjectElement cfg objects (oid, o) = - (mkelem en (as ++ eas)+ mkelem en (as ++ eas) ([ selem "dc:title" [ txt $ sanitizeXmlChars $ objectTitle od ] , selem "upnp:class" [ txt $ getObjectClassName o ] ] ++ ee)- ) where od = getObjectData o en = getObjectElementName o ee = generateExtraElements cfg (oid,o)- as = [ sattr "id" $ oid + as = [ sattr "id" oid , sattr "parentID" $ objectParentId od ] eas = generateExtraAttributes objects (oid,o)@@ -305,13 +302,10 @@ where playSpeed = 1 :: Int -- DLNA play speed: Normal conversionFlags = -- DLNA conversion flags- case transcode of- False -> 0 :: Int- True -> 1 :: Int+ if transcode then 1 else 0 :: Int operationsParameter = -- DLNA operations parameter- case transcode of- False -> 1 :: Int -- Support byte ranges, but not time seek ranges.- True -> 0 :: Int -- Don't support bytes ranges, nor time seek ranges.+ if transcode then 0 :: Int -- Don't support bytes ranges, nor time seek ranges.+ else 1 -- Support byte ranges, but not time seek ranges. flags = _DLNA_ORG_FLAG_STREAMING_TRANSFER_MODE .|. _DLNA_ORG_FLAG_BACKGROUND_TRANSFER_MODE .|.@@ -326,9 +320,10 @@ , ("DLNA.ORG_FLAGS" , Just $ printf "%08x%024x" flags (0 :: Int32) ) ] protocolPrefix = "http-get:*:" ++ mimeType ++ ":" protocolSuffix = - case useDlna cfg of- True -> join ";" $ mapMaybe (\(n,v) -> mapMaybe1 (printf "%s=%s" n) v) fields- False -> "*"+ if useDlna cfg then+ join ";" $ mapMaybe (\(n,v) -> mapMaybe1 (printf "%s=%s" n) v) fields+ else + "*" -- Protocol constants. _DLNA_ORG_FLAG_SENDER_PACED = bit 31 :: Int32 _DLNA_ORG_FLAG_TIME_BASED_SEEK = bit 30 :: Int32@@ -359,11 +354,11 @@ -- Create the DIDL result object. mkDidl :: ArrowXml a => [a XmlTree XmlTree] -> a XmlTree XmlTree 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 ])+ 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/"@@ -372,4 +367,4 @@ -- Slice out a portion of a list. slice :: Int -> Int -> [a] -> [a]-slice i n xs = take n $ drop i $ xs+slice i n = take n . drop i
src/SimpleServiceDiscoveryProtocol.hs view
@@ -48,7 +48,7 @@ , printf "\r\n" ] where base_url = show $ mkURI ["description.xml"] $ httpServerBase c- messageTypeAsString UpnpServiceNotification = (printf "uuid:%s" $ uuid msc)+ messageTypeAsString UpnpServiceNotification = printf "uuid:%s" $ uuid msc messageTypeAsString RootDeviceNotification = "upnp:rootdevice" messageTypeAsString ConnectionManagerNotification = "urn:schemas-upnp-org:service:ConnectionManager:1" messageTypeAsString ContentDirectoryNotification = "urn:schemas-upnp-org:service:ContentDirectory:1"@@ -60,7 +60,7 @@ sendRawMessage :: Configuration -> String -> IO () sendRawMessage c m = do -- Addresses- sa <- inet_addr $ local_net_ip c+ sa <- inet_addr $ localNetIp c da <- inet_addr "239.255.255.250" -- Open socket and send sock <- socket AF_INET Datagram 0@@ -70,8 +70,8 @@ return () sendNotifyAlive :: ApplicationInformation -> Configuration -> MediaServerConfiguration -> MessageType -> IO ()-sendNotifyAlive ai c msc mt = - sendRawMessage c $ generateNotifyAlive ai c msc mt+sendNotifyAlive ai c msc = + sendRawMessage c . generateNotifyAlive ai c msc sendNotifyAliveAll :: ApplicationInformation -> Configuration -> MediaServerConfiguration -> IO () sendNotifyAliveAll ai c msc = do@@ -86,7 +86,7 @@ threadDelay 100000 sendNotifyForever :: ApplicationInformation -> Configuration -> MediaServerConfiguration -> IO ()-sendNotifyForever ai c msc = do+sendNotifyForever ai c msc = forever $ do putStrLn "Broadcasting alive notifications..." sendNotifyAliveAll ai c msc
src/StorableExtra.hs view
@@ -26,9 +26,8 @@ -- Convert a storable to an [Word8]. toWord8Array :: Storable a => a -> IO [Word8]-toWord8Array a = do- xs <- loop 0- return xs+toWord8Array a =+ loop 0 where loop i = if i < sizeOf a then do@@ -43,5 +42,5 @@ toHexString :: Storable a => a -> IO String toHexString a = do bytes <- toWord8Array a- let s = (concat $ map (\x -> printf "%02x" x) $ bytes) :: String - return $ s+ let s = concatMap (printf "%02x") bytes :: String + return s
src/URIExtra.hs view
@@ -39,7 +39,7 @@ addSlashes [] = [] addSlashes ("":xs) = addSlashes xs -- Remove empty components addSlashes [x] = [x] -- Last component-addSlashes (x:y:xs) = (addSlash x : addSlashes (y:xs)) -- Other components+addSlashes (x:y:xs) = addSlash x : addSlashes (y:xs) -- Other components -- Add trailing slash to a string unless already present. addSlash :: String -> String