diff --git a/hums.cabal b/hums.cabal --- a/hums.cabal +++ b/hums.cabal @@ -1,5 +1,5 @@ Name: hums -Version: 0.6.0 +Version: 0.7.0 Synopsis: Haskell UPnP Media Server Description: A simple UPnP Media Server. . @@ -21,8 +21,6 @@ Build-Depends: base == 4.* , blaze-builder >= 0.3 && <0.4 , bytestring >= 0.9.0.1 - , conduit >= 1.1 && <2 - , conduit-extra >= 1.1 && <2 , ConfigFile >= 1.0.5 , containers >= 0.1.0.1 , directory >= 1.0.0.0 @@ -33,7 +31,6 @@ , MissingH >= 1.0.1 , mtl >= 2.1 , network >= 2.4.1 && < 2.5 - , parsec >= 3.0 && < 3.2 , system-uuid >= 2.1 && < 2.2 , system-filepath >= 0.4.7 && < 0.5 , system-fileio >= 0.3.10 && < 0.4 @@ -42,10 +39,9 @@ , unix >= 2.5.0.0 , unordered-containers >= 0.2 && < 0.3 , case-insensitive >= 1.2 - , wai >= 2.0 && < 3 - , warp >= 2.0 && < 3 + , wai >= 3.0.0.2 && < 4 + , warp >= 3.0 && < 4 Default-Extensions: Arrows - GeneralizedNewtypeDeriving OverloadedStrings ScopedTypeVariables Ghc-Options: -Wall -fno-warn-unused-matches -threaded diff --git a/src/DirectoryUtils.hs b/src/DirectoryUtils.hs --- a/src/DirectoryUtils.hs +++ b/src/DirectoryUtils.hs @@ -19,7 +19,7 @@ module DirectoryUtils ( walkTree ) where -import Control.Exception (catch, SomeException) +import Control.Exception (catch) import Control.Monad import Data.List import qualified Data.Text as T @@ -43,12 +43,11 @@ -- file name of the file/directory being visited. walkTree :: a -> (a -> a -> FileStatus -> FilePath -> IO a) -> FilePath -> IO a walkTree s0 f d = do - -- FIXME: Need to detect loops! -- Get files and directories in directory. If that fails -- we just pretend there are none. allNames <- catch (listDirectory d) - (\(e :: SomeException) -> do + (\(e :: IOError) -> do putStrLn $ "Error retrieving directory contents: " ++ show e -- Log errors return []) -- Sort diff --git a/src/Handlers.hs b/src/Handlers.hs --- a/src/Handlers.hs +++ b/src/Handlers.hs @@ -25,22 +25,20 @@ ) where import Blaze.ByteString.Builder (fromByteString) +import Control.Exception (bracket) import Data.ByteString (ByteString) -import qualified Data.ByteString as S +import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as L -import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI -import Data.Conduit (Flush(..), ($$), mapOutput) -import qualified Data.Conduit.List as CL -import Data.Conduit.Binary (sourceHandleRange) import Data.IORef (IORef, readIORef) +import Data.List (foldl') import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8) -import Network.HTTP.Types (Status, Header, partialContent206, forbidden403, notImplemented501, ok200, notFound404) +import Network.HTTP.Types (Status, Header, partialContent206, forbidden403, badRequest400, ok200, notFound404) import Network.HTTP.Types.Header (hConnection, hContentLength, hContentType) -import Network.Wai (Application, Request, Response, responseSourceBracket, requestBody, requestHeaders, responseLBS) +import Network.Wai (Application, Request, Response, responseStream, requestBody, requestHeaderRange, responseLBS) import Filesystem.Path (FilePath, ()) import Filesystem.Path.CurrentOS (encodeString, fromText) import qualified Filesystem as FS @@ -75,18 +73,21 @@ serveStaticFile req mimeType fp = do logMessage $ printf "Serving file '%s'..." $ sfp -- Do we have a range header? - let ranges = case lookup rangeHeader $ requestHeaders req of - Just value -> parseRangeHeader $ B8.unpack value - Nothing -> [(Nothing, Nothing)] -- whole file - -- Serve the ranges. - fsz <- FS.getSize fp - response <- serveFile fsz ranges - return $ response + case requestHeaderRange req of + Just value -> + case parseRangeHeader value of + Just (l, h) -> serve (Just l, h) + Nothing -> sendError badRequest400 + Nothing -> + serve (Nothing, Nothing) where - sfp :: String + serve range = do + fsz <- FS.getSize fp + return $ serveFile fsz range + sfp = encodeString fp - serveFile fsz [(l,h)] = do + serveFile fsz (l,h) = do let l' = maybe 0 id l let h' = maybe (fsz-1) id h let n = (h' - l' + 1) @@ -95,19 +96,27 @@ , hdrContentRange l' h' fsz , hdrAcceptRangesBytes , hdrConnectionClose ] - let src hnd = mapOutput (Chunk . fromByteString) $ sourceHandleRange hnd (Just l') (Just n) - responseSourceBracket - (IO.openFile sfp IO.ReadMode) - (IO.hClose) - (\hnd -> return (partialContent206, hdrs, src hnd)) + responseStream partialContent206 hdrs $ \write _ -> + bracket + (IO.openFile sfp IO.ReadMode) + IO.hClose + (\hnd -> do + IO.hSeek hnd IO.AbsoluteSeek l' + streamBody hnd write $ fromIntegral n) - serveFile _ _ = do - -- This requires multipart/byteranges, but we don't support that as of yet. - sendError notImplemented501 + bufSize = 32768 + streamBody hnd write = go + where + go 0 = return () + go n = B.hGet hnd (min bufSize n) >>= \s -> + case B.length s of + 0 -> return () + n' -> write (fromByteString s) >> go (n - n') + -- Handler for the root description. rootDescriptionHandler :: State -> IO Response -rootDescriptionHandler (c,mc,ai,s,_) = do +rootDescriptionHandler (c,mc,_,s,_) = do logMessage "Got request for root description." let xml = generateDescriptionXml c mc s return $ responseLBS ok200 [ hdrConnectionClose @@ -124,13 +133,13 @@ else serveStaticFile req mimeType fp where - fp = foldl () root (map fromText path) + fp = foldl' () root (map fromText path) mimeType = guessMimeType fp dotDot = ".." -- Handle requests for content. contentHandler :: Request -> State -> Text -> IO Response -contentHandler req (c,mc,ai,s,objects_) oid = do +contentHandler req (_,_,_,_,objects_) oid = do objects <- readIORef objects_ -- Current snapshot of object tree. logMessage $ printf "Got request for CONTENT for objectId=%s" (T.unpack oid) -- Serve the file which the object maps to. @@ -146,32 +155,25 @@ -- Handle requests for device CONTROL urls. serviceControlHandler :: State -> DeviceType -> Application -serviceControlHandler (c,mc,ai,s,objects_) deviceType req = do +serviceControlHandler (c,_,_,_,objects_) deviceType req respond = do objects <- readIORef objects_ -- Current snapshot of object tree. logMessage $ printf "Got request for CONTROL for service '%s'" $ deviceTypeToString deviceType -- Parse the SOAP request - requestXml <- fmap S.concat $ requestBody req $$ CL.consume + requestXml <- requestBody req logMessage $ "Request: " ++ (show requestXml) action <- parseControlSoapXml $ T.unpack $ decodeUtf8 requestXml logMessage $ "Action: " ++ (show action) -- Deal with the action case action of - Just a -> do - xml_ <- case a of - ContentDirectoryAction_ cda -> handleCDA deviceType cda objects - ConnectionManagerAction_ cma -> handleCMA cma - return xml_ - Nothing -> - sendError notFound404 - where - handleCDA st a objects = do - sendXml $ generateActionResponseXml c st objects a - handleCMA _ = + Just (ContentDirectoryAction_ cda) -> + sendXml (generateActionResponseXml c deviceType objects cda) >>= respond + Just (ConnectionManagerAction_ _) -> -- 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. - sendError notFound404 - + sendError notFound404 >>= respond + Nothing -> + sendError notFound404 >>= respond -- Last resort handler. fallbackHandler :: IO Response @@ -205,10 +207,6 @@ hdrContentLength :: (Show a, Integral a) => a -> Header hdrContentLength l = (hContentLength, encodeUtf8 $ T.pack $ show l) - --- Name of the range header. -rangeHeader :: CI ByteString -rangeHeader = CI.mk "range" -- XML content type xmlContentType :: Header diff --git a/src/HttpExtra.hs b/src/HttpExtra.hs --- a/src/HttpExtra.hs +++ b/src/HttpExtra.hs @@ -19,45 +19,29 @@ module HttpExtra ( parseRangeHeader ) where -import Text.ParserCombinators.Parsec - -parseRange :: GenParser Char a (Maybe Integer, Maybe Integer) -parseRange = - choice [parseFullRange, - parseEndRange, - parseSingleByteRange] - -parseFullRange :: GenParser Char a (Maybe Integer, Maybe Integer) -parseFullRange = do - i1 <- parseInteger - _ <- char '-' - i2 <- optionMaybe parseInteger - return (Just i1, i2) - -parseEndRange :: GenParser Char a (Maybe Integer, Maybe Integer) -parseEndRange = do - _ <- char '-' - i1 <- parseInteger - return (Just $ -i1, Nothing) - -parseSingleByteRange :: GenParser Char a (Maybe Integer, Maybe Integer) -parseSingleByteRange = do - i1 <- parseInteger - _ <- char '-' - return (Just i1, Just i1) - -parseInteger :: GenParser Char a Integer -parseInteger = do - ds <- many1 digit - return (read ds :: Integer) +import Data.ByteString.Char8 (isPrefixOf, ByteString) +import qualified Data.ByteString.Char8 as B8 -parseRanges :: GenParser Char a [(Maybe Integer, Maybe Integer)] -parseRanges = do - _ <- string "bytes=" - parseRange `sepBy` char ',' +-- Strip a prefix of a byte string and return the suffix (if the +-- prefix was actually a prefix). +parseLiteral :: ByteString -> ByteString -> Maybe ByteString +parseLiteral p s = + case p `isPrefixOf` s of + False -> Nothing + True -> Just $ B8.drop (B8.length p) s -parseRangeHeader :: String -> [(Maybe Integer, Maybe Integer)] -parseRangeHeader s = - case parse parseRanges "-" s of - Left err -> [] -- Ignore if we can't parse - Right rs -> rs +-- Parse the Range header sent by the PS/3. The Range header that the +-- PS/3 send is always in a very simple format, so we shortcut this to +-- avoid the complexity of full HTTP/1.1 range headers. +parseRangeHeader :: ByteString -> Maybe (Integer, Maybe Integer) +parseRangeHeader s = do + -- Extract the first part of the range + s' <- parseLiteral "bytes=" s + (startI, s'') <- B8.readInteger s' + s''' <- parseLiteral "-" s'' + -- The second part of the range is optional. + if B8.length s''' == 0 then + return $ (startI, Nothing) + else do + (endI, _) <- B8.readInteger s''' + return (startI, Just endI) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -16,6 +16,8 @@ along with this program. If not, see . -} +module Main (main) where + import Control.Concurrent import Control.Monad.Error import Data.ConfigFile @@ -68,20 +70,20 @@ return objects application :: State -> FilePath -> Application -application state dataDirectory request = do +application state dataDirectory request respond = do case pathInfo request of ["description.xml"] -> - rootDescriptionHandler state + rootDescriptionHandler state >>= respond ("static" : path) -> - staticHandler request (dataDirectory staticDir) path + staticHandler request (dataDirectory staticDir) path >>= respond ("dynamic" : "services" : "ContentDirectory" : "control" : _) -> - serviceControlHandler state ContentDirectoryDevice request + serviceControlHandler state ContentDirectoryDevice request respond ("dynamic" : "services" : "ConnectionManager" : "control" : _) -> - serviceControlHandler state ConnectionManagerDevice request + serviceControlHandler state ConnectionManagerDevice request respond ["content" , objectId ] -> - contentHandler request state objectId + contentHandler request state objectId >>= respond _ -> - fallbackHandler + fallbackHandler >>= respond where staticDir = decodeString "www" diff --git a/src/Object.hs b/src/Object.hs --- a/src/Object.hs +++ b/src/Object.hs @@ -36,6 +36,7 @@ import qualified Data.ByteString.Char8 as B8 import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as H +import Data.List (foldl') import qualified Data.Text as T import Data.Int import Data.Word (Word8) @@ -144,8 +145,6 @@ [] -> rootObjectId ((oid,_):_) -> oid -- Compute object id for the directory entry. - -- FIXME: Should handle 'file gone missing' -- simply don't prepend an - -- object in that case. deviceId <- toHexString $ P.deviceID st fileId <- toHexString $ P.fileID st let oid = T.pack $ printf "%s,%s" deviceId fileId @@ -183,7 +182,7 @@ -- Construct the objects map. return Objects { mapIdToObject = H.fromList o' - , mapParentToChildren = foldl p2c H.empty o' + , mapParentToChildren = foldl' p2c H.empty o' , systemUpdateId = maximum $ map (objectLastModified . getObjectData . snd) o' } where diff --git a/src/URIExtra.hs b/src/URIExtra.hs --- a/src/URIExtra.hs +++ b/src/URIExtra.hs @@ -21,7 +21,7 @@ ) where import Network.URI (URI, relativeTo, parseRelativeReference, escapeURIString, isUnescapedInURI) -import Data.List +import Data.List (foldl', isSuffixOf) -- Create an URI reference (absolute or relative URI with optional fragment identifier) -- from an arbitrary string. The string is URI-encoded if necessary. @@ -52,4 +52,4 @@ mkURI' :: URI -> [URI] -> URI mkURI' = - foldl (\a r -> r `relativeTo` a) + foldl' (\a r -> r `relativeTo` a)