hums 0.2.5 → 0.2.6
raw patch · 11 files changed
+67/−36 lines, 11 filesdep +network-bytestringdep −sendfiledep ~basedep ~hxt
Dependencies added: network-bytestring
Dependencies removed: sendfile
Dependency ranges changed: base, hxt
Files
- hums.cabal +5/−4
- src/DirectoryUtils.hs +0/−1
- src/HttpExtra.hs +4/−4
- src/HttpServer.hs +3/−4
- src/Main.hs +5/−10
- src/MimeType.hs +9/−7
- src/Object.hs +0/−3
- src/SendFile.hs +40/−0
- src/Service.hs +0/−1
- src/SimpleServiceDiscoveryProtocol.hs +1/−1
- src/StorableExtra.hs +0/−1
hums.cabal view
@@ -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 <bardur@scientician.net>-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
src/DirectoryUtils.hs view
@@ -19,7 +19,6 @@ module DirectoryUtils ( walkTree ) where -import System.IO import System.Directory import Control.Monad import System.FilePath
src/HttpExtra.hs view
@@ -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)]
src/HttpServer.hs view
@@ -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 ()
src/Main.hs view
@@ -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
src/MimeType.hs view
@@ -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
src/Object.hs view
@@ -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
+ src/SendFile.hs view
@@ -0,0 +1,40 @@+{-+ 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/>.+-}++--+-- 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))
src/Service.hs view
@@ -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
src/SimpleServiceDiscoveryProtocol.hs view
@@ -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 ()
src/StorableExtra.hs view
@@ -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]