diff --git a/hums.cabal b/hums.cabal --- a/hums.cabal +++ b/hums.cabal @@ -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 diff --git a/src/Action.hs b/src/Action.hs --- a/src/Action.hs +++ b/src/Action.hs @@ -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) diff --git a/src/Configuration.hs b/src/Configuration.hs --- a/src/Configuration.hs +++ b/src/Configuration.hs @@ -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" diff --git a/src/Didl.hs b/src/Didl.hs --- a/src/Didl.hs +++ b/src/Didl.hs @@ -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/" diff --git a/src/DirectoryUtils.hs b/src/DirectoryUtils.hs --- a/src/DirectoryUtils.hs +++ b/src/DirectoryUtils.hs @@ -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 diff --git a/src/HttpExtra.hs b/src/HttpExtra.hs --- a/src/HttpExtra.hs +++ b/src/HttpExtra.hs @@ -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 = diff --git a/src/HttpServer.hs b/src/HttpServer.hs --- a/src/HttpServer.hs +++ b/src/HttpServer.hs @@ -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" diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 () diff --git a/src/Object.hs b/src/Object.hs --- a/src/Object.hs +++ b/src/Object.hs @@ -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 diff --git a/src/RegexExtra.hs b/src/RegexExtra.hs --- a/src/RegexExtra.hs +++ b/src/RegexExtra.hs @@ -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) diff --git a/src/Service.hs b/src/Service.hs --- a/src/Service.hs +++ b/src/Service.hs @@ -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 diff --git a/src/SimpleServiceDiscoveryProtocol.hs b/src/SimpleServiceDiscoveryProtocol.hs --- a/src/SimpleServiceDiscoveryProtocol.hs +++ b/src/SimpleServiceDiscoveryProtocol.hs @@ -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 diff --git a/src/StorableExtra.hs b/src/StorableExtra.hs --- a/src/StorableExtra.hs +++ b/src/StorableExtra.hs @@ -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 diff --git a/src/URIExtra.hs b/src/URIExtra.hs --- a/src/URIExtra.hs +++ b/src/URIExtra.hs @@ -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