diff --git a/hums.cabal b/hums.cabal --- a/hums.cabal +++ b/hums.cabal @@ -1,5 +1,5 @@ Name: hums -Version: 0.3.2 +Version: 0.3.3 Synopsis: Haskell UPnP Media Server Description: A simple UPnP Media Server. . @@ -21,7 +21,6 @@ Build-Depends: base == 4.* , haskell98 , network == 2.3.* - , HTTP == 4000.1.* , filepath >= 1.1.0.0 , parsec >= 2.1.0.0 && < 3.0 , unix >= 2.3.0.0 @@ -29,16 +28,24 @@ , containers >= 0.1.0.1 , uuid >= 1.2.1 && < 1.3 , bytestring >= 0.9.0.1 + , blaze-builder == 0.2.* , MissingH >= 1.0.1 , hxt >= 9.0.1 , ConfigFile >= 1.0.5 , mtl == 2.0.* , transformers == 0.2.* - , hashmap == 1.1.* - , text == 0.10.* + , unordered-containers == 0.1.* + , text == 0.11.* , HaXml == 1.20.* - Extensions: Arrows GeneralizedNewtypeDeriving - ghc-options: -Wall -fno-warn-unused-matches -threaded + , enumerator >= 0.4.9 + , http-types >= 0.6 && <0.7 + , case-insensitive >= 0.2 && < 0.3 + , wai >= 0.4 && < 0.5 + , warp >= 0.4 && < 0.5 + Extensions: Arrows + GeneralizedNewtypeDeriving + OverloadedStrings + ghc-options: -Wall -O2 -fno-warn-unused-matches -threaded hs-source-dirs: src Main-is: Main.hs Other-modules: Action @@ -46,12 +53,9 @@ DirectoryUtils Handlers HttpExtra - HttpMonad - HttpServer MimeType Object Paths_hums - SendFile Service SimpleServiceDiscoveryProtocol Soap diff --git a/src/Action.hs b/src/Action.hs --- a/src/Action.hs +++ b/src/Action.hs @@ -24,7 +24,9 @@ , ObjectId ) where -type ObjectId = String +import Data.ByteString (ByteString) + +type ObjectId = ByteString data BrowseParameters = BrowseParameters { objectId :: ObjectId diff --git a/src/Configuration.hs b/src/Configuration.hs --- a/src/Configuration.hs +++ b/src/Configuration.hs @@ -24,7 +24,6 @@ , parseConfiguration ) where -import Data.Word import System.Posix.Unistd (SystemID(..), getSystemID) import Text.Printf import Network.URI (URI, parseURI) @@ -42,7 +41,7 @@ data Configuration = Configuration { localNetIp :: String , httpServerBase :: URI - , httpServerPort :: Word16 + , httpServerPort :: Int , enableDeviceIcon :: Bool , useDlna :: Bool , dlnaProfileName :: Maybe String -- Only used when useDlna is available. diff --git a/src/Handlers.hs b/src/Handlers.hs --- a/src/Handlers.hs +++ b/src/Handlers.hs @@ -21,28 +21,37 @@ , serviceControlHandler , contentHandler , fallbackHandler + , State ) where import Soap import Configuration -import Network.HTTP.Base -import Network.HTTP.Headers -import Network.StreamSocket() import Service import Text.Printf import Action +import Blaze.ByteString.Builder (insertByteString) import System.IO (withFile, hFileSize, IOMode(..)) import MimeType import Object import HttpExtra import System.FilePath -import Data.ByteString.Lazy (ByteString) +import Data.ByteString (ByteString, isInfixOf) +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import Data.List (isInfixOf) +import qualified Data.ByteString.Char8 as B8 import Data.IORef -import HttpMonad import Control.Monad.Trans.Class (lift) -import Control.Monad.IO.Class (MonadIO) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Network.Wai +import Data.Enumerator (Iteratee, ($$), ($=)) +import Data.Enumerator.Binary (enumFileRange) +import qualified Data.Enumerator as E +import qualified Data.Enumerator.List as EL +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Network.HTTP.Types (Status, Header, status206, statusServerError, statusOK, statusNotFound, headerContentType, headerContentLength, headerConnection) +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI type State = (Configuration, MediaServerConfiguration, ApplicationInformation, [DeviceType], IORef Objects) @@ -59,124 +68,102 @@ -} - -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 - 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 :: String -> FilePath -> HttpT IO () -serveStaticFile mimeType fp = do +serveStaticFile :: Request -> ByteString -> FilePath -> Iteratee ByteString IO Response +serveStaticFile req mimeType fp = do logMessage $ printf "Serving file '%s'..." fp -- Do we have a range header? - hs <- fmap getHeaders getRequest - let ranges = - case lookupHeader HdrRange hs of - Just value -> parseRangeHeader value - Nothing -> [] -- Whole file - - -- Set up the common headers. - addHeader (Header HdrContentType mimeType) - addHeader (Header (HdrCustom "Accept-Ranges") "bytes") - addHeader (Header HdrConnection "close") - + let ranges = case lookup rangeHeader $ requestHeaders req of + Just value -> parseRangeHeader $ B8.unpack value + Nothing -> [(Nothing, Nothing)] -- whole file -- Serve the ranges. fsz <- lift $ fileSize fp - let ranges' = hCanonicalizeRanges fsz ranges - serveFile fsz ranges' + serveFile fsz ranges where - serveFile fsz [] = do - -- Set the headers for full transfer. - setResponseCode OK - setContentLength $ Just fsz - -- Send the file contents. - writeFileToBody fp 0 fsz - serveFile fsz [(rLow,rHigh)] = do - -- Set the headers for partial content. - setResponseCode PartialContent - setContentLength $ Just (rHigh-rLow+1) - addHeader (Header HdrContentRange $ printf "%d-%d/%d" rLow rHigh fsz) - -- Send the file contents. - writeFileToBody fp rLow $ fromInteger $ rHigh - rLow + 1 - serveFile _ _ = - -- This requires multipart/byteranges, but we don't support that as of yet. - sendError NotImplemented - + serveFile fsz [(l,h)] = do + let l' = maybe 0 id l + let h' = maybe (fsz-1) id h + let n = (h' - l' + 1) + return $ ResponseEnumerator $ \f -> + E.run_ $ (enumFileRange fp l h $= EL.map insertByteString) $$ f status206 + [ hdrContentLength n + , headerContentType mimeType + , hdrContentRange l' h' fsz + , hdrAcceptRangesBytes + , hdrConnectionClose + ] + serveFile _ _ = do + -- This requires multipart/byteranges, but we don't support that as of yet. + sendError statusServerError -- Regular expressions for avoiding relative URLs. These -- are overly conservative, but what the heck... -dotDotSlash :: String +dotDotSlash :: ByteString dotDotSlash = "../" -slashDotDot :: String +slashDotDot :: ByteString slashDotDot = "/.." -- Handler for the root description. -rootDescriptionHandler :: State -> HttpT IO () +rootDescriptionHandler :: State -> Iteratee ByteString IO Response rootDescriptionHandler (c,mc,ai,s,_) = do logMessage "Got request for root description." - sendXml $ generateDescriptionXml c mc s - logMessage "Sent root description." + let xml = generateDescriptionXml c mc s + return $ responseLBS statusOK [ hdrConnectionClose + , hdrContentLength (L.length xml) + , headerContentType "text/xml" + ] xml -- Handle static files. -staticHandler :: String -> String -> HttpT IO () -staticHandler root p = do - logMessage $ "Got request for static content: " ++ p +staticHandler :: Request -> String -> ByteString -> Iteratee ByteString IO Response +staticHandler req root p = do + logMessage $ "Got request for static content: " ++ (show p) if dotDotSlash `isInfixOf` p || -- Reject relative URLs. slashDotDot `isInfixOf` p then - sendError InternalServerError + sendError statusServerError else - serveStaticFile mimeType fp - where - fp = root p - mimeType = guessMimeType fp + serveStaticFile req mimeType fp + where + fp = root (T.unpack $ decodeUtf8 p) + mimeType = guessMimeType fp -- Handle requests for content. -contentHandler :: State -> String -> HttpT IO () -contentHandler (c,mc,ai,s,objects_) oid = do +contentHandler :: Request -> State -> ByteString -> Iteratee ByteString IO Response +contentHandler req (c,mc,ai,s,objects_) oid = do objects <- lift $ readIORef objects_ -- Current snapshot of object tree. - logMessage $ printf "Got request for CONTENT for objectId=%s" oid + logMessage $ printf "Got request for CONTENT for objectId=%s" (B8.unpack oid) -- Serve the file which the object maps to. case findByObjectId oid objects of Just o -> - serveStaticFile mt fp + serveStaticFile req mt fp where od = getObjectData o fp = objectFileName od mt = objectMimeType od Nothing -> - sendError NotFound + sendError statusNotFound -- Handle requests for device CONTROL urls. -serviceControlHandler :: State -> DeviceType -> String -> HttpT IO () +serviceControlHandler :: State -> DeviceType -> ByteString -> Iteratee ByteString IO Response serviceControlHandler (c,mc,ai,s,objects_) deviceType _ = do objects <- lift $ readIORef objects_ -- Current snapshot of object tree. logMessage $ printf "Got request for CONTROL for service '%s'" $ deviceTypeToString deviceType -- Parse the SOAP request - requestXml <- fmap rqBody getRequest - logMessage $ printf "Request: %s" requestXml - action <- lift $ parseControlSoapXml requestXml - logMessage $ printf "Action: %s" $ show action + requestXml <- fmap S.concat EL.consume + logMessage $ "Request: " ++ (show requestXml) + action <- lift $ 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 () + return xml_ Nothing -> - sendError NotImplemented + sendError statusNotFound where handleCDA st a objects = do sendXml $ generateActionResponseXml c st objects a @@ -184,30 +171,47 @@ -- 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 NotImplemented + sendError statusNotFound -- Last resort handler. -fallbackHandler :: HttpT IO () +fallbackHandler :: Iteratee ByteString IO Response fallbackHandler = do - r <- getRequest - logMessage $ printf "Fallback handler got request: %s" $ show r - sendError InternalServerError + return $ responseLBS statusNotFound [] "" -- Send an empty error response. -sendError :: Monad m => HttpResponseCode -> HttpT m () -sendError c = do - setResponseCode c - setContentLength $ Just 0 - addHeader (Header HdrConnection "close") +sendError :: Monad m => Status -> Iteratee ByteString m Response +sendError s = return $ + responseLBS s [ hdrConnectionClose + , hdrContentLength (0 :: Integer) + ] "" -- Send generated XML. -sendXml :: (MonadIO m, Functor m) => ByteString -> HttpT m () -sendXml xml = do - setResponseCode OK - setContentLength $ Just $ toInteger $ L.length xml - addHeader (Header HdrConnection "close") - addHeader (Header HdrContentType "text/xml") - -- logMessage $ "Sending XML:" - -- logDataLBS xml - writeToBody xml +sendXml :: (MonadIO m, Functor m) => L.ByteString -> Iteratee ByteString m Response +sendXml xml = return $ + responseLBS statusOK [ hdrConnectionClose + , hdrContentLength (L.length xml) + , headerContentType "text/xml" + ] xml + +logMessage :: (MonadIO m, Functor m) => String -> Iteratee a m () +logMessage m = do + liftIO $ putStrLn m + +-- Convenience functions for DRY construction of headers. +hdrConnectionClose :: Header +hdrConnectionClose = headerConnection "close" + +hdrAcceptRangesBytes :: Header +hdrAcceptRangesBytes = (CI.mk "accept-ranges", "bytes") + +hdrContentRange :: Integer -> Integer -> Integer -> Header +hdrContentRange l h s = (CI.mk "content-range", B8.pack $ printf "%d-%d/%d" l h s) + +hdrContentLength :: Integral a => a -> Header +hdrContentLength l = headerContentLength $ encodeUtf8 $ T.pack $ show l + +-- Name of the range header. +rangeHeader :: CI ByteString +rangeHeader = CI.mk "range" + diff --git a/src/HttpMonad.hs b/src/HttpMonad.hs deleted file mode 100644 --- a/src/HttpMonad.hs +++ /dev/null @@ -1,175 +0,0 @@ -{- - hums - The Haskell UPnP Server - Copyright (C) 2009-2010 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 . --} -module HttpMonad ( HttpT - , runHttp - , HttpResponseCode(..) - , addHeader - , setResponseCode - , setContentLength - , writeToBody - , writeFileToBody - , logDataLBS - , logMessage - , getRequest - , ifPrefix - , ifPath - ) where - -import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.Trans.State.Strict -import Control.Monad.Trans.Reader -import Control.Applicative -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad (unless) -import Network.HTTP.Base (ResponseCode, Response(..), Request(..), urlDecode) -import Network.HTTP.Headers (Header(..), HeaderName(..)) -import Network.StreamSocket() -import Network.URI (uriPath) -import Data.ByteString (ByteString) -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import Data.List (stripPrefix) -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) -import SendFile (sendFile) -import Text.Printf (printf) - --- HTTP response codes. -data HttpResponseCode = OK - | PartialContent - | NotFound - | InternalServerError - | NotImplemented - --- Convert HTTP response code to a numeric code and string. -mapStatusCode :: HttpResponseCode -> (ResponseCode, String) -mapStatusCode OK = ((2,0,0), "OK") -mapStatusCode NotFound = ((4,0,4), "Not Found") -mapStatusCode InternalServerError = ((5,0,4), "Internal Server Error") -mapStatusCode NotImplemented = ((5,0,1), "Not Implemented") -mapStatusCode PartialContent = ((2,0,6), "Partial Content") - --- State of the HTTP writer monad. -data HttpState = - HttpState { hHeaders :: [Header] - , hHeadersFlushed :: Bool - , hStatusCode :: HttpResponseCode - , hOutput :: ByteString -> IO () - } - -type Req = Request String - --- Newtype wrapper for HttpT for implementation hiding. -newtype HttpT m a = HttpT { unHttp :: ReaderT Req (StateT HttpState m) a } - deriving (Functor, Monad) - --- Instances -instance MonadTrans HttpT where - lift m = HttpT $ (lift . lift) m - --- Run a Http computation. -runHttp :: (Functor m, Monad m, MonadIO m) => (ByteString -> IO ()) -> Request String -> HttpT m a -> m a -runHttp output request m = do - evalStateT (runReaderT (unHttp m') request) s0 - where - s0 = HttpState [] False OK output - m' = do - a <- m - flushHeaders -- Just in case we haven't written any data. - return a - --- Add header to the response. -addHeader :: Monad m => Header -> HttpT m () -addHeader header = HttpT $ do - lift $ modify $ \st -> st { hHeaders = header : hHeaders st } - --- Set content length. -setContentLength :: Monad m => Maybe Integer -> HttpT m () -setContentLength (Just n) = addHeader (Header HdrContentLength $ printf "%d" n) -- FIXME: Replace! -setContentLength Nothing = return () -- FIXME: Remove! - - --- Flush all the headers. -flushHeaders :: (Functor m, Monad m, MonadIO m) => HttpT m () -flushHeaders = HttpT $ lift $ do - -- Ignore if already flushed. - alreadyFlushed <- hHeadersFlushed <$> get - unless alreadyFlushed $ do - -- Generate the headers. - output <- hOutput <$> get - headers <- hHeaders <$> get - (code,reason) <- fmap mapStatusCode $ hStatusCode <$> get - let sResponse = show $ Response { rspCode = code - , rspReason = reason - , rspHeaders = headers - , rspBody = "" } - -- Output the headers. - lift $ liftIO $ output $ encodeUtf8 $ T.pack sResponse - -- We've flushed the headers. - modify (\s -> s { hHeadersFlushed = True }) - --- Set the response code. -setResponseCode :: Monad m => HttpResponseCode -> HttpT m () -setResponseCode c = HttpT $ lift $ do - modify $ \st -> st { hStatusCode = c } - --- Write to body. -writeToBody :: (Functor m, MonadIO m, Monad m) => L.ByteString -> HttpT m () -writeToBody buf = HttpT $ do - output <- lift $ hOutput <$> get - unHttp $ flushHeaders - lift $ liftIO $ output $ S.concat $ L.toChunks buf -- FIXME: Maybe change "output" to use lazy? - --- Write the contents of a file to body. -writeFileToBody :: (Functor m, MonadIO m, Monad m) => FilePath -> Integer -> Integer -> HttpT m () -writeFileToBody buf offset count = HttpT $ do - output <- lift $ hOutput <$> get - unHttp $ flushHeaders - lift $ liftIO $ sendFile output buf offset count - --- Logging. -logMessage :: (Monad m, MonadIO m) => String -> HttpT m () -logMessage s = HttpT $ liftIO $ putStrLn s - -logDataLBS :: (Monad m, MonadIO m) => L.ByteString -> HttpT m () -logDataLBS s = HttpT $ liftIO $ L.putStrLn s - --- Get request. -getRequest :: (Functor m, Monad m) => HttpT m (Request String) -getRequest = HttpT $ ask - --- Dispatch based on a test-and-forward function. -dispatchOn :: (Functor m, Monad m) => (String -> Maybe a) -> (a -> HttpT m ()) -> HttpT m () -> HttpT m () -dispatchOn p ifMatch ifNoMatch = do - request <- getRequest - case p $ urlDecode $ uriPath $ rqURI request of - Just r -> ifMatch r - Nothing -> ifNoMatch - --- Match request prefix. The request path is stripped of the prefix --- before being forwarded to the handler. -ifPrefix :: (Functor m, Monad m) => String -> (String -> HttpT m ()) -> HttpT m () -> HttpT m () -ifPrefix p = dispatchOn (stripPrefix p) - --- Match full request path. -ifPath :: (Functor m, Monad m) => String -> HttpT m () -> HttpT m () -> HttpT m () -ifPath p ifMatch ifNoMatch = - dispatchOn predicate ifMatch' ifNoMatch - where - predicate p' = if p == p' then Just () else Nothing - ifMatch' _ = ifMatch diff --git a/src/HttpServer.hs b/src/HttpServer.hs deleted file mode 100644 --- a/src/HttpServer.hs +++ /dev/null @@ -1,67 +0,0 @@ -{- - 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 . --} - -module HttpServer ( runHttpServer - ) where - -import Network.HTTP.Base -import Network.HTTP.Stream -import Network.Socket -import Network.StreamSocket() -import Control.Monad -import Control.Concurrent -import Control.Exception -import Data.Word -import HttpMonad (HttpT, runHttp) -import Network.Socket.ByteString (sendAll) - --- Request handlers. -type RequestHandler = - Socket -> Request String -> IO () - -runHttpServer' :: RequestHandler -> Word16 -> IO () -runHttpServer' r p = do - let p' = fromIntegral p :: PortNumber - let sa = SockAddrInet p' iNADDR_ANY - s <- socket AF_INET Stream 0 - setSocketOption s ReuseAddr 1 - bindSocket s sa - listen s 5 - forever $ acceptConnection s r - -acceptConnection :: Socket -> RequestHandler -> IO () -acceptConnection listenSocket r = do - (s,_) <- accept listenSocket - _ <- forkIO $ bracket - (return s) - sClose - (handleHttpConnection r) - return () -- Don't care about the thread ID. - -handleHttpConnection :: RequestHandler -> Socket -> IO () -handleHttpConnection r c = do - result <- receiveHTTP c - case result of - Left _ -> error "Error reading request" - Right req -> r c req - -runHttpServer :: HttpT IO () -> Word16 -> IO () -runHttpServer handler = runHttpServer' myRequestHandler - where - myRequestHandler :: Socket -> Request String -> IO () - myRequestHandler s r = runHttp (sendAll s) r $ handler diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -19,9 +19,7 @@ import Network.Utils import SimpleServiceDiscoveryProtocol import Configuration -import Network.StreamSocket() import Control.Concurrent -import HttpServer import Service import Text.Printf import qualified Data.UUID as U @@ -34,7 +32,11 @@ import Paths_hums import Data.IORef import Handlers -import HttpMonad (ifPath, ifPrefix) +import Network.Wai (Application, Response, Request(..)) +import Network.Wai.Handler.Warp (run) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Enumerator (Iteratee) defaultMediaServerConfiguration :: String -> MediaServerConfiguration defaultMediaServerConfiguration uuid_ = @@ -63,52 +65,64 @@ putStrLn $ printf "Scanning completed" return objects +handleIf :: (Maybe a) -> (a -> Iteratee ByteString IO Response) -> Iteratee ByteString IO Response -> Iteratee ByteString IO Response +handleIf Nothing _ noMatch = noMatch +handleIf (Just x) match _ = match x + main :: IO () main = niceSocketsDo $ do - -- Get the data directory. - dataDirectory <- getDataFileName "." - -- Parse configuration. - c <- parseConfiguration emptyCP $ dataDirectory "hums.cfg" - print c + -- Get the data directory. + dataDirectory <- getDataFileName "." - -- Scan objects once at the start. - let scanOnce' = scanOnce $ rootDirectory c - defaultObjects_ <- scanOnce' - defaultObjects <- newIORef defaultObjects_ + -- Parse configuration. + c <- parseConfiguration emptyCP $ dataDirectory "hums.cfg" + print c - -- Get the application information. - appInfo <- getApplicationInformation + -- Scan objects once at the start. + let scanOnce' = scanOnce $ rootDirectory c + defaultObjects_ <- scanOnce' + defaultObjects <- newIORef defaultObjects_ - -- Build configurations, etc. - u <- fmap (U.toString . fromJust) U1.nextUUID - putStrLn $ "My UUID is: " ++ u - let mc = defaultMediaServerConfiguration u - let services = [ ContentDirectoryDevice, ConnectionManagerDevice ] - let st = (c,mc,appInfo,services, defaultObjects) + -- Get the application information. + appInfo <- getApplicationInformation - let handlers = - ifPath "/description.xml" (rootDescriptionHandler st) $ - ifPrefix "/static/" (staticHandler $ dataDirectory "www") $ - ifPrefix "/dynamic/services/ContentDirectory/control" (serviceControlHandler st ContentDirectoryDevice) $ - ifPrefix "/dynamic/services/ConnectionManager/control" (serviceControlHandler st ConnectionManagerDevice) $ - ifPrefix "/content/" (contentHandler st) $ - fallbackHandler + -- Build configurations, etc. + u <- fmap (U.toString . fromJust) U1.nextUUID + putStrLn $ "My UUID is: " ++ u + let mc = defaultMediaServerConfiguration u + let services = [ ContentDirectoryDevice, ConnectionManagerDevice ] + let st = (c,mc,appInfo,services, defaultObjects) - -- Start serving. - putStrLn "Establishing HTTP server..." - _ <- forkIO $ runHttpServer handlers $ httpServerPort c - _ <- putStrLn "Done." + let myApplication :: Application + myApplication r = + ifPath "/description.xml" (\_ -> rootDescriptionHandler st) $ + ifPrefix "/static/" (staticHandler r $ dataDirectory "www") $ + ifPrefix "/dynamic/services/ContentDirectory/control" (serviceControlHandler st ContentDirectoryDevice) $ + ifPrefix "/dynamic/services/ConnectionManager/control" (serviceControlHandler st ConnectionManagerDevice) $ + ifPrefix "/content/" (contentHandler r st) $ + fallbackHandler + where + ifPath p t f = handleIf (isPath p) t f + ifPrefix p t f = handleIf (isPrefix p) t f + isPath p = if rawPathInfo r == p then Just () else Nothing + isPrefix p | B.isPrefixOf p $ rawPathInfo r = Just $ B.drop (B.length p) $ rawPathInfo r + isPrefix _ = Nothing - -- Start broadcasting alive messages. - putStrLn "Establishing notification broadcaster..." - _ <- forkIO $ sendNotifyForever appInfo c mc + -- Start serving. + putStrLn "Establishing HTTP server..." + _ <- forkIO $ run (httpServerPort c) myApplication + _ <- putStrLn "Done." - -- Start scanning files/directories in the background. - putStrLn "Establishing background scanner..." - _ <- forkIO $ periodicUpdate defaultObjects scanOnce' + -- Start broadcasting alive messages. + putStrLn "Establishing notification broadcaster..." + _ <- forkIO $ sendNotifyForever appInfo c mc - -- Wait for all threads to terminate. - interact id + -- Start scanning files/directories in the background. + putStrLn "Establishing background scanner..." + _ <- forkIO $ periodicUpdate defaultObjects scanOnce' - return () + -- Wait for all threads to terminate. + interact id + + return () diff --git a/src/MimeType.hs b/src/MimeType.hs --- a/src/MimeType.hs +++ b/src/MimeType.hs @@ -19,15 +19,18 @@ module MimeType ( guessMimeType ) where +import Data.ByteString (ByteString) +import Data.ByteString.Char8 () import System.FilePath -- A primitive MIME type guesser. We use a custom one instead of the -- relatively standard /etc/mime.types since UPnP media server clients -- can be finicky about which MIME types they accept. -guessMimeType :: FilePath -> String +guessMimeType :: FilePath -> ByteString guessMimeType fp = mimeType $ takeExtension fp where + mimeType :: String -> ByteString mimeType ".xml" = "text/xml" mimeType ".avi" = "video/divx" -- PlayStation 3 oddity ('x-msvideo' is standard) mimeType ".mp3" = "audio/mpeg" diff --git a/src/Object.hs b/src/Object.hs --- a/src/Object.hs +++ b/src/Object.hs @@ -31,10 +31,11 @@ ) where import Action +import Data.ByteString (ByteString, isPrefixOf) +import qualified Data.ByteString.Char8 as B8 import Data.Char (isAscii) -import Data.HashMap (HashMap) -import qualified Data.HashMap as H -import Data.List (isPrefixOf) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as H import DirectoryUtils import System.FilePath import MimeType @@ -52,7 +53,7 @@ rootObjectParentId = "-1" -- Dispatch table for selecting item type from MIME type. -mimeTypeToObjectType :: String -> Maybe ObjectType +mimeTypeToObjectType :: ByteString -> Maybe ObjectType mimeTypeToObjectType s | ("video/" `isPrefixOf` s) = Just ItemVideoMovie mimeTypeToObjectType s | ("audio/" `isPrefixOf` s) = Just ItemMusicTrack mimeTypeToObjectType s | ("inode/directory" == s) = Just ContainerStorageFolder @@ -74,7 +75,7 @@ , objectFileName :: FilePath -- Physical file. , objectFileSize :: Integer -- The size of the physical file. , objectLastModified :: Int64 - , objectMimeType :: String -- MIME type of the file. + , objectMimeType :: ByteString -- MIME type of the file. } deriving (Show) @@ -127,7 +128,7 @@ findExistingByObjectId oid os = case findByObjectId oid os of Just x -> x - Nothing -> error $ printf "Couldn't find object '%s'" oid + Nothing -> error $ printf "Couldn't find object '%s'" $ B8.unpack oid -- Accumulator function for building the basic list of files/directories. scanFile :: [(ObjectId, Object)] -> [(ObjectId, Object)] -> FilePath -> IO [(ObjectId, Object)] @@ -142,7 +143,7 @@ st <- getFileStatus fp deviceId <- toHexString $ deviceID st fileId <- toHexString $ fileID st - let oid = printf "%s,%s" deviceId fileId + let oid = B8.pack $ printf "%s,%s" deviceId fileId -- Compute the update ID. let lastModified = round' $ toRational $ modificationTime st -- Compute file size. @@ -192,8 +193,6 @@ , objectMimeType = "inode/directory" })) p2c acc (oid, o) = - H.alter (\x -> case x of - Nothing -> Just [oid] - Just cs -> Just (oid:cs)) pid acc + H.insertWith (++) pid [oid] acc where pid = objectParentId $ getObjectData o diff --git a/src/SendFile.hs b/src/SendFile.hs deleted file mode 100644 --- a/src/SendFile.hs +++ /dev/null @@ -1,37 +0,0 @@ -{- - 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 . --} - -module SendFile ( sendFile - ) where - -import Data.ByteString (hGet, ByteString) -import qualified Data.ByteString as BS -import System.IO (hSeek, withFile, IOMode(..), SeekMode(..)) - --- Send contents of a file. -sendFile :: (ByteString -> IO ()) -> FilePath -> Integer -> Integer -> IO () -sendFile output 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) - output 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 @@ -38,6 +38,7 @@ import qualified Data.Text.Lazy as T import Data.Text.Lazy.Encoding (decodeUtf8) import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Char8 as B8 myQuote :: Text -> Text myQuote = -- TODO: There *must* be a better way to achieve our quoting needs. @@ -117,7 +118,7 @@ generateIconList True = (simpleElement "iconList" [ simpleElement "icon" - [ textElement "mimetype" $ guessMimeType imageUrl + [ textElement "mimetype" $ B8.unpack $ guessMimeType imageUrl , textElement "width" "240" , textElement "height" "240" , textElement "url" imageUrl @@ -247,7 +248,7 @@ ) ) where - soapNs = attribute "xmlns:s" $ printf "%s/envelope/" urlPrefix + soapNs = attribute "xmlns:s" $ (urlPrefix ++ "/envelope/") soapEncodingStyle = attribute "s:encodingStyle" $ printf "%s/encoding/" urlPrefix urlPrefix = "http://schemas.xmlsoap.org/soap" @@ -264,8 +265,8 @@ od = getObjectData o en = getObjectElementName o ee = generateExtraElements cfg (oid,o) - as = [ attribute "id" oid - , attribute "parentID" $ objectParentId od + as = [ attribute "id" $ B8.unpack oid + , attribute "parentID" $ B8.unpack $ objectParentId od ] eas = generateExtraAttributes objects (oid,o) @@ -295,9 +296,9 @@ [ contentUrl ] ] where - mimeType = objectMimeType d + mimeType = B8.unpack $ objectMimeType d protocolInfo = generateProtocolInfo cfg False mimeType Nothing -- TODO: profileId - contentUrl = text $ show $ mkURI ["content", oid] $ httpServerBase cfg + contentUrl = text $ show $ mkURI ["content", B8.unpack $ oid] $ httpServerBase cfg mapMaybe1 :: (a -> b) -> Maybe a -> Maybe b mapMaybe1 f Nothing = Nothing @@ -328,7 +329,7 @@ protocolPrefix = "http-get:*:" ++ mimeType ++ ":" protocolSuffix = if useDlna cfg then - join ";" $ mapMaybe (\(n,v) -> mapMaybe1 (printf "%s=%s" n) v) fields + join ";" $ mapMaybe (\(n,v) -> mapMaybe1 (\v' -> n ++ "=" ++ v') v) fields else "*" -- Protocol constants. diff --git a/src/SimpleServiceDiscoveryProtocol.hs b/src/SimpleServiceDiscoveryProtocol.hs --- a/src/SimpleServiceDiscoveryProtocol.hs +++ b/src/SimpleServiceDiscoveryProtocol.hs @@ -48,14 +48,14 @@ , printf "\r\n" ] where base_url = show $ mkURI ["description.xml"] $ httpServerBase c - messageTypeAsString UpnpServiceNotification = printf "uuid:%s" $ uuid msc + messageTypeAsString UpnpServiceNotification = "uuid:" ++ (uuid msc) messageTypeAsString RootDeviceNotification = "upnp:rootdevice" messageTypeAsString ConnectionManagerNotification = "urn:schemas-upnp-org:service:ConnectionManager:1" messageTypeAsString ContentDirectoryNotification = "urn:schemas-upnp-org:service:ContentDirectory:1" messageTypeAsString MediaServerNotification = "urn:schemas-upnp-org:device:MediaServer:1" messageTypeSuffix = case messageType of UpnpServiceNotification -> "" - _ -> printf "::%s" $ messageTypeAsString messageType + _ -> "::" ++ (messageTypeAsString messageType) sendRawMessage :: Configuration -> String -> IO () sendRawMessage c m = do diff --git a/src/Soap.hs b/src/Soap.hs --- a/src/Soap.hs +++ b/src/Soap.hs @@ -19,6 +19,7 @@ module Soap ( parseControlSoapXml ) where +import qualified Data.ByteString.Char8 as B8 import Text.XML.HXT.Core import Action @@ -62,7 +63,7 @@ si <- numberAtTag "StartingIndex" -< l rq <- numberAtTag "RequestedCount" -< l sc <- textAtTag "SortCriteria" -< l - returnA -< let bps = BrowseParameters oid flt si rq sc in + returnA -< let bps = BrowseParameters (B8.pack oid) flt si rq sc in ContentDirectoryBrowse $ bf bps parseCDSearchCapabilities :: ArrowXml a => a XmlTree ContentDirectoryAction