diff --git a/hums.cabal b/hums.cabal --- a/hums.cabal +++ b/hums.cabal @@ -1,5 +1,5 @@ Name: hums -Version: 0.2.5 +Version: 0.2.6 Synopsis: Haskell UPnP Media Server Description: A simple UPnP Media Server. . @@ -11,7 +11,7 @@ Build-type: Simple Author: Bardur Arantsson Maintainer: Bardur Arantsson -Build-Depends: base >= 3 && <4, +Build-Depends: base == 4.*, haskell98, network >= 2.2.0.1, HTTP >= 4000.0.8, @@ -24,10 +24,10 @@ uuid >= 1.0.0, bytestring >= 0.9.0.1, MissingH >= 1.0.1, - hxt >= 8.3.1 && < 8.4, + hxt >= 8.3.1 && < 8.6, ConfigFile >= 1.0.5, mtl >= 1.1.0.2, - sendfile >= 0.6.1 && < 0.7 + network-bytestring >= 0.1.2.1 && <0.2 data-dir: data data-files: hums.cfg www/images/hums.jpg @@ -55,3 +55,4 @@ Action Object Didl + SendFile diff --git a/src/DirectoryUtils.hs b/src/DirectoryUtils.hs --- a/src/DirectoryUtils.hs +++ b/src/DirectoryUtils.hs @@ -19,7 +19,6 @@ module DirectoryUtils ( walkTree ) where -import System.IO import System.Directory import Control.Monad import System.FilePath diff --git a/src/HttpExtra.hs b/src/HttpExtra.hs --- a/src/HttpExtra.hs +++ b/src/HttpExtra.hs @@ -30,20 +30,20 @@ parseFullRange :: GenParser Char a (Maybe Integer, Maybe Integer) parseFullRange = do i1 <- parseInteger - char '-' + _ <- char '-' i2 <- optionMaybe parseInteger return (Just i1, i2) parseEndRange :: GenParser Char a (Maybe Integer, Maybe Integer) parseEndRange = do - char '-' + _ <- char '-' i1 <- parseInteger return (Just $ -i1, Nothing) parseSingleByteRange :: GenParser Char a (Maybe Integer, Maybe Integer) parseSingleByteRange = do i1 <- parseInteger - char '-' + _ <- char '-' return (Just i1, Just i1) parseInteger :: GenParser Char a Integer @@ -53,7 +53,7 @@ parseRanges :: GenParser Char a [(Maybe Integer, Maybe Integer)] parseRanges = do - string "bytes=" + _ <- string "bytes=" parseRange `sepBy` char ',' parseRangeHeader :: String -> [(Maybe Integer, Maybe Integer)] diff --git a/src/HttpServer.hs b/src/HttpServer.hs --- a/src/HttpServer.hs +++ b/src/HttpServer.hs @@ -32,7 +32,6 @@ import Network.HTTP.Stream import Network.Socket import Network.StreamSocket() -import System.IO import Control.Monad import Control.Concurrent import Control.Exception @@ -63,7 +62,7 @@ acceptConnection :: Socket -> RequestHandler -> IO () acceptConnection listenSocket r = do (s,_) <- accept listenSocket - forkIO $ bracket + _ <- forkIO $ bracket (return s) sClose (handleHttpConnection r) @@ -83,14 +82,14 @@ , rspReason = rReason , rspHeaders = rHeaders , rspBody = "" } - writeBlock conn $ show rsp -- Writes headers only + CRLF. + _ <- writeBlock conn $ show rsp -- Writes headers only + CRLF. return () -- Write data to body of request. May be called multiple times after -- sendHeaders has been called. sendBody :: Stream s => s -> String -> IO () sendBody conn body = do - writeBlock conn body + _ <- writeBlock conn body return () diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -27,7 +27,6 @@ import HttpServer import Service import Text.Regex -import Data.List import Text.Printf import Action import System.IO (withFile, hFileSize, IOMode(..)) @@ -43,7 +42,7 @@ import Paths_hums import Data.IORef import Network.Socket (Socket) -import Network.Socket.SendFile (sendFile', sendFileMode) +import SendFile (sendFile') defaultMediaServerConfiguration :: String -> MediaServerConfiguration defaultMediaServerConfiguration uuid_ = @@ -281,10 +280,6 @@ let services = [ ContentDirectoryDevice, ConnectionManagerDevice ] let st = (c,mc,appInfo,services, defaultObjects) - -- Extra information for debugging: - putStrLn $ printf "SendFile mode: %s" sendFileMode - - -- Build URL dispatch table let dispatchTable = [ (mkRegex "^/description\\.xml$", rootDescriptionHandler st) , (mkRegex "^/static/(.*)$", staticHandler $ dataDirectory "www") @@ -295,16 +290,16 @@ -- Start serving. putStrLn "Establishing HTTP server..." - forkIO $ runHttpServer dispatchTable $ httpServerPort c - putStrLn "Done." + _ <- forkIO $ runHttpServer dispatchTable $ httpServerPort c + _ <- putStrLn "Done." -- Start broadcasting alive messages. putStrLn "Establishing notification broadcaster..." - forkIO $ sendNotifyForever appInfo c mc + _ <- forkIO $ sendNotifyForever appInfo c mc -- Start scanning files/directories in the background. putStrLn "Establishing background scanner..." - forkIO $ periodicUpdate defaultObjects scanOnce' + _ <- forkIO $ periodicUpdate defaultObjects scanOnce' -- Wait for all threads to terminate. interact id diff --git a/src/MimeType.hs b/src/MimeType.hs --- a/src/MimeType.hs +++ b/src/MimeType.hs @@ -28,10 +28,12 @@ guessMimeType fp = mimeType $ takeExtension fp where - mimeType ".xml" = "text/xml" - mimeType ".avi" = "video/divx" -- PlayStation 3 oddity ('x-msvideo' is standard) - mimeType ".mp3" = "audio/mpeg" - mimeType ".mpg" = "video/mpeg" - mimeType ".jpg" = "image/jpeg" - mimeType ".mp4" = "video/mp4" - mimeType _ = "application/octet-stream" -- Reasonable default + mimeType ".xml" = "text/xml" + mimeType ".avi" = "video/divx" -- PlayStation 3 oddity ('x-msvideo' is standard) + mimeType ".mp3" = "audio/mpeg" + mimeType ".mpg" = "video/mpeg" + mimeType ".m2ts" = "video/mpeg" + mimeType ".m2t" = "video/mpeg" + mimeType ".jpg" = "image/jpeg" + mimeType ".mp4" = "video/mp4" + mimeType _ = "application/octet-stream" -- Reasonable default diff --git a/src/Object.hs b/src/Object.hs --- a/src/Object.hs +++ b/src/Object.hs @@ -34,10 +34,7 @@ import Data.Map (Map) import qualified Data.Map as Map import DirectoryUtils -import Data.Maybe -import System.IO import System.FilePath -import Data.List import MimeType import Data.Int import System.Posix diff --git a/src/SendFile.hs b/src/SendFile.hs new file mode 100644 --- /dev/null +++ b/src/SendFile.hs @@ -0,0 +1,40 @@ +{- + 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 . +-} + +-- +-- This exists because Network.Socket.SendFile isn't usable on Linux as of 0.4. +-- +module SendFile ( sendFile' + ) where + +import Data.ByteString as BS (hGet, length) +import Network.Socket.ByteString (sendAll) +import Network.Socket (Socket) +import System.IO (hSeek, withFile, IOMode(..), SeekMode(..)) + +sendFile' :: Socket -> FilePath -> Integer -> Integer -> IO () +sendFile' outs inp off count = do + withFile inp ReadMode (\h -> do + hSeek h AbsoluteSeek off + rsend h count) + where rsend h 0 = return () + rsend h reqBytes = do + let bytes = min 32768 reqBytes :: Integer + buf <- hGet h (fromIntegral bytes) + sendAll outs buf + rsend h (reqBytes - (fromIntegral $ BS.length buf)) diff --git a/src/Service.hs b/src/Service.hs --- a/src/Service.hs +++ b/src/Service.hs @@ -26,7 +26,6 @@ import Text.Printf import Configuration import Action -import Data.AssocList (addEntries) import Data.Maybe (mapMaybe) import Object import Data.List.Utils diff --git a/src/SimpleServiceDiscoveryProtocol.hs b/src/SimpleServiceDiscoveryProtocol.hs --- a/src/SimpleServiceDiscoveryProtocol.hs +++ b/src/SimpleServiceDiscoveryProtocol.hs @@ -65,7 +65,7 @@ -- Open socket and send sock <- socket AF_INET Datagram 0 bindSocket sock $ SockAddrInet aNY_PORT sa -- Use local interface - sendTo sock m (SockAddrInet 1900 da) -- Ignore return value + _ <- sendTo sock m (SockAddrInet 1900 da) -- Ignore return value sClose sock return () diff --git a/src/StorableExtra.hs b/src/StorableExtra.hs --- a/src/StorableExtra.hs +++ b/src/StorableExtra.hs @@ -22,7 +22,6 @@ import Data.Word import Foreign.Marshal.Utils (with) import Text.Printf -import Control.Monad -- Convert a storable to an [Word8]. toWord8Array :: Storable a => a -> IO [Word8]