hums 0.2.6 → 0.3.0
raw patch · 11 files changed
+485/−447 lines, 11 filesdep +transformersdep +utf8-stringdep ~hxt
Dependencies added: transformers, utf8-string
Dependency ranges changed: hxt
Files
- hums.cabal +8/−5
- src/DirectoryUtils.hs +20/−8
- src/Handlers.hs +221/−0
- src/HttpMonad.hs +139/−0
- src/HttpServer.hs +8/−93
- src/Main.hs +16/−209
- src/Object.hs +9/−10
- src/RegexExtra.hs +0/−39
- src/SendFile.hs +7/−10
- src/Service.hs +31/−39
- src/Soap.hs +26/−34
hums.cabal view
@@ -1,5 +1,5 @@ Name: hums-Version: 0.2.6+Version: 0.3.0 Synopsis: Haskell UPnP Media Server Description: A simple UPnP Media Server. .@@ -23,10 +23,12 @@ containers >= 0.1.0.1, uuid >= 1.0.0, bytestring >= 0.9.0.1,+ utf8-string == 0.3.*, MissingH >= 1.0.1,- hxt >= 8.3.1 && < 8.6,+ hxt == 9.*, ConfigFile >= 1.0.5,- mtl >= 1.1.0.2,+ mtl >= 1.1.0.2, + transformers == 0.2.*, network-bytestring >= 0.1.2.1 && <0.2 data-dir: data data-files: hums.cfg @@ -35,7 +37,7 @@ www/services/ContentDirectory/description.xml Executable: hums-Extensions: Arrows+Extensions: Arrows GeneralizedNewtypeDeriving ghc-options: -Wall -fno-warn-unused-matches -threaded hs-source-dirs: src Main-is: Main.hs@@ -45,8 +47,9 @@ URIExtra SimpleServiceDiscoveryProtocol HttpExtra- RegexExtra+ HttpMonad Service+ Handlers Configuration Soap DirectoryUtils
src/DirectoryUtils.hs view
@@ -33,8 +33,13 @@ walkTree :: a -> (a -> a -> FilePath -> IO a) -> FilePath -> IO a walkTree s0 f d = do -- FIXME: Need to detect loops!- -- Get files and directories in directory.- allNames <- getDirectoryContents d+ -- Get files and directories in directory. If that fails+ -- we just pretend there are none.+ allNames <- catch + (getDirectoryContents d) + (\e -> do+ putStrLn $ "Error retrieving directory contents: " ++ show e -- Log errors+ return []) -- Filter out the special directories. let names = sort $ filter (not . isSpecialDirectory) allNames -- Produce full names.@@ -43,12 +48,19 @@ foldM traverse s0 fullNames where traverse s n = do- isDirectory <- doesDirectoryExist n- if isDirectory then do- s' <- f s0 s n- walkTree s' f n- else- f s0 s n+ isFile <- doesFileExist n+ case isFile of+ True -> f s0 s n+ False -> do+ isDirectory <- doesDirectoryExist n+ case isDirectory of+ True -> do + s' <- f s0 s n+ walkTree s' f n+ False -> do+ -- Not a directory nor an existing file. Conclusion: A dead symlink.+ putStrLn $ "Ignoring dead symbolic link: " ++ (show n)+ return s isSpecialDirectory ".." = True isSpecialDirectory "." = True
+ src/Handlers.hs view
@@ -0,0 +1,221 @@+{-+ 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/>.+-}++module Handlers ( rootDescriptionHandler+ , staticHandler+ , serviceControlHandler+ , contentHandler+ , fallbackHandler+ ) where++import Soap+import Configuration+import Network.HTTP.Base+import Network.HTTP.Headers+import Network.StreamSocket()+import Service+import Text.Regex+import Text.Printf+import Action+import System.IO (withFile, hFileSize, IOMode(..))+import MimeType+import Object+import HttpExtra+import System.FilePath+import Data.Maybe (isJust)+import Data.IORef+import HttpMonad+import Control.Monad.Trans.Class (lift)+import Data.ByteString.UTF8 (fromString)+import Control.Monad.IO.Class (MonadIO)++type State = (Configuration, MediaServerConfiguration, ApplicationInformation, [DeviceType], IORef Objects)++{-++ RFC2616 (HTTP/1.1) compliance issues:++ - No conditional range support.+ - Can only handle single ranges.+ - Negative range indexes are not supported.+ - Handling of invalid range specifications is non-compliant.++ It does work well enough for the PS3 though :).++-}+++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+ 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")++ -- Serve the ranges.+ fsz <- lift $ fileSize fp+ let ranges' = hCanonicalizeRanges 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+++-- Regular expressions for avoiding relative URLs. These+-- are overly conservative, but what the heck...+dotDotSlash :: Regex+dotDotSlash = mkRegex "\\.\\./"+slashDotDot :: Regex+slashDotDot = mkRegex "/\\.\\."++-- Handler for the root description.+rootDescriptionHandler :: State -> [String] -> HttpT IO ()+rootDescriptionHandler (c,mc,ai,s,_) gs = do+ logMessage "Got request for root description."+ xml <- lift $ generateDescriptionXml c mc s+ sendXml xml+ logMessage "Sent root description."++-- Handle static files.+staticHandler :: String -> [String] -> HttpT IO ()+staticHandler root gs = do+ logMessage $ "Got request for static content: " ++ show gs+ case gs of+ [p] -> if isJust (matchRegex dotDotSlash p) || -- Reject relative URLs.+ isJust (matchRegex slashDotDot p) then+ sendError InternalServerError+ else+ serveStaticFile mimeType fp+ where+ fp = root </> p+ mimeType = guessMimeType fp+ _ ->+ sendError InternalServerError++-- Handle requests for content.+contentHandler :: State -> [String] -> HttpT IO ()+contentHandler (c,mc,ai,s,objects_) gs = do+ objects <- lift $ readIORef objects_ -- Current snapshot of object tree.+ case gs of+ [oid] -> do+ logMessage $ printf "Got request for CONTENT for objectId=%s" oid+ -- Serve the file which the object maps to.+ case findByObjectId oid objects of+ Just o ->+ serveStaticFile mt fp+ where+ od = getObjectData o+ fp = objectFileName od+ mt = objectMimeType od+ Nothing ->+ sendError NotFound+ _ ->+ sendError InternalServerError++-- Handle requests for device CONTROL urls.+serviceControlHandler :: State -> DeviceType -> [String] -> HttpT IO ()+serviceControlHandler (c,mc,ai,s,objects_) deviceType gs = 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+ -- 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 ()+ Nothing ->+ sendError NotImplemented+ where+ handleCDA st a objects = do+ xml <- lift $ generateActionResponseXml c st objects a+ logMessage $ printf "Response: %s" $ xml+ sendXml xml+ 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.+ sendError NotImplemented+++-- Last resort handler.+fallbackHandler :: HttpT IO ()+fallbackHandler = do+ r <- getRequest+ logMessage $ printf "Fallback handler got request: %s" $ show r+ sendError InternalServerError++-- Send an empty error response.+sendError :: Monad m => HttpResponseCode -> HttpT m ()+sendError c = do+ setResponseCode c+ setContentLength $ Just 0+ addHeader (Header HdrConnection "close")++-- Send generated XML.+sendXml :: (Monad m, MonadIO m, Functor m) => String -> HttpT m ()+sendXml xml = do+ setResponseCode OK+ setContentLength $ Just $ toEnum $ length xml+ addHeader (Header HdrConnection "close")+ addHeader (Header HdrContentType "text/xml")+ writeToBody $ fromString $ xml
+ src/HttpMonad.hs view
@@ -0,0 +1,139 @@+module HttpMonad ( HttpT+ , runHttp+ , HttpResponseCode(..)+ , addHeader+ , setResponseCode+ , setContentLength+ , writeToBody+ , writeFileToBody+ , logMessage+ , getRequest+ , ifRegex+ ) 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 Data.ByteString.UTF8 (fromString)+import SendFile (sendFile)+import Text.Printf (printf)+import Text.Regex (matchRegex, mkRegex)++-- 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 $ fromString 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) => ByteString -> HttpT m ()+writeToBody buf = HttpT $ do+ output <- lift $ hOutput <$> get+ unHttp $ flushHeaders+ lift $ liftIO $ output buf++-- 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++-- Get request.+getRequest :: (Functor m, Monad m) => HttpT m (Request String)+getRequest = HttpT $ ask++-- Match request prefix.+ifRegex :: (Functor m, Monad m) => String -> ([String] -> HttpT m ()) -> HttpT m () -> HttpT m ()+ifRegex r ifMatch ifNoMatch = do+ request <- getRequest+ case matchRegex re $ urlDecode $ uriPath $ rqURI request of+ Just gs -> ifMatch gs+ Nothing -> ifNoMatch+ where+ re = mkRegex r
src/HttpServer.hs view
@@ -17,18 +17,9 @@ -} module HttpServer ( runHttpServer- , UrlHandler- , sendHeaders- , sendErrorResponse- , sendOkHeaders- , sendBody- , sendXmlResponse- , sendPartialContentHeaders- , HttpError(..) ) where import Network.HTTP.Base-import Network.HTTP.Headers import Network.HTTP.Stream import Network.Socket import Network.StreamSocket()@@ -36,19 +27,13 @@ import Control.Concurrent import Control.Exception import Data.Word-import Text.Regex-import Text.Printf-import Network.URI-import RegexExtra+import HttpMonad (HttpT, runHttp)+import Network.Socket.ByteString (sendAll) -- Request handlers.-type RequestHandler = +type RequestHandler = Socket -> Request String -> IO () --- URL handlers.-type UrlHandler = - Socket -> Request String -> [String] -> IO ()- runHttpServer' :: RequestHandler -> Word16 -> IO () runHttpServer' r p = do let p' = fromIntegral p :: PortNumber@@ -62,7 +47,7 @@ acceptConnection :: Socket -> RequestHandler -> IO () acceptConnection listenSocket r = do (s,_) <- accept listenSocket- _ <- forkIO $ bracket + _ <- forkIO $ bracket (return s) sClose (handleHttpConnection r)@@ -75,78 +60,8 @@ Left _ -> error "Error reading request" Right req -> r c req --sendHeaders :: Socket -> ResponseCode -> String -> [Header] -> IO ()-sendHeaders conn rCode rReason rHeaders = do- let rsp = Response { rspCode = rCode- , rspReason = rReason- , rspHeaders = rHeaders- , rspBody = "" }- _ <- 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- return ()----myRequestHandler :: [(Regex, UrlHandler)] -> Socket -> Request String -> IO ()-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 = runHttpServer' . myRequestHandler--{--- Response generator functions.---}--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) -> 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- let h3 = Header HdrConnection "close" in- sendHeaders conn (2,0,6) "Partial Content" (h1 : h2 : h3 : hs)- ---sendXmlResponse :: Socket -> [Header] -> String -> IO ()-sendXmlResponse conn hs xml = do- sendOkHeaders conn ( Header HdrContentType "text/xml" : hs ) $ toEnum $ length xml- sendBody conn xml------data HttpError = NotFound- | InternalServerError- | NotImplemented- --sendErrorResponse :: Socket -> HttpError -> [Header] -> IO ()-sendErrorResponse conn e hs =- sendHeaders conn c r- ([ Header HdrContentLength "0"- , Header HdrConnection "close"- ] ++ hs)+runHttpServer :: HttpT IO () -> Word16 -> IO ()+runHttpServer handler = runHttpServer' myRequestHandler where- (c,r) = case e of- NotFound -> ((4,0,4),"NOT FOUND") - InternalServerError -> ((5,0,4), "INTERNAL SERVER ERROR")- NotImplemented -> ((5,0,1), "NOT IMPLEMENTED")+ myRequestHandler :: Socket -> Request String -> IO ()+ myRequestHandler s r = runHttp (sendAll s) r $ handler
src/Main.hs view
@@ -16,36 +16,28 @@ along with this program. If not, see <http://www.gnu.org/licenses/>. -} -import Soap import Network.Utils import SimpleServiceDiscoveryProtocol-import Configuration -import Network.HTTP.Base-import Network.HTTP.Headers+import Configuration import Network.StreamSocket() import Control.Concurrent import HttpServer import Service-import Text.Regex import Text.Printf-import Action-import System.IO (withFile, hFileSize, IOMode(..)) import qualified Data.UUID as U import qualified Data.UUID.V1 as U1-import MimeType import Object-import HttpExtra import Control.Monad.Error import System.FilePath-import Data.Maybe (fromJust, isJust)+import Data.Maybe (fromJust) import Data.ConfigFile import Paths_hums import Data.IORef-import Network.Socket (Socket)-import SendFile (sendFile')+import Handlers+import HttpMonad (ifRegex) defaultMediaServerConfiguration :: String -> MediaServerConfiguration-defaultMediaServerConfiguration uuid_ = +defaultMediaServerConfiguration uuid_ = MediaServerConfiguration { uuid = uuid_ , friendlyName = "hums" , manufacturer = "Bardur Arantsson"@@ -58,189 +50,6 @@ , upc = Nothing } -type State = (Configuration, MediaServerConfiguration, ApplicationInformation, [DeviceType], IORef Objects)---rootDescriptionHandler :: State -> Socket -> Request String -> [String] -> IO ()-rootDescriptionHandler (c,mc,ai,s,_) conn r gs = do- putStrLn "Got request for root description."- xml <- generateDescriptionXml c mc s- putStrLn "Generated root description."- sendXmlResponse conn (getExtraHeaders ai) xml- putStrLn "Send root description."--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 :: FilePath -> Socket -> [(Integer,Integer)] -> IO ()-hCopyRanges src conn ranges =- mapM_ copyRange ranges- where- copyRange (lo, hi) = hCopyBytes src conn lo $ fromInteger $ hi - lo + 1--{--- RFC2616 (HTTP/1.1) compliance issues:-- - No conditional range support.- - Can only handle single ranges.- - Negative range indexes are not supported.- - Handling of invalid range specifications is non-compliant.-- It does work well enough for the PS3 though :).---}---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 :: Socket -> [Header] -> String -> FilePath -> IO ()-serveStaticFile conn hs mimeType fp = do- putStrLn $ printf "Serving file '%s'..." fp-- -- Do we have a range header?- let ranges = - case lookupHeader HdrRange hs of- Just value -> parseRangeHeader value- Nothing -> [] -- Whole file-- -- Serve the ranges.- fsz <- fileSize fp- let ranges' = hCanonicalizeRanges fsz ranges- serveFile fsz ranges'- where - ohs = [ Header HdrContentType mimeType ]- serveFile :: Integer -> [(Integer,Integer)] -> IO ()- serveFile fsz [] = do- -- No range given (or all ranges were invalid), so we handle regularly.- sendOkHeaders conn ohs fsz- hCopyBytes fp conn 0 fsz- serveFile fsz [r] = do- -- Send headers- sendPartialContentHeaders conn ohs r fsz- -- Copy data from ranges into body.- 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."----- Regular expressions for avoiding relative URLs. These--- are overly conservative, but what the heck...-dotDotSlash :: Regex-dotDotSlash = mkRegex "\\.\\./"-slashDotDot :: Regex-slashDotDot = mkRegex "/\\.\\." ---- Handle static files.-staticHandler :: String -> Socket -> Request String -> [String] -> IO ()-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- sendErrorResponse conn InternalServerError []- else- serveStaticFile conn (getHeaders req) mimeType fp- where - fp = root </> p- mimeType = guessMimeType fp- _ -> sendErrorResponse conn InternalServerError []- ----- TODO: Should we generate a DATE header?-getExtraHeaders :: ApplicationInformation -> [ Header ]-getExtraHeaders ai = [ Header (HdrCustom "contentFeatures.dlna.org") ""- , Header (HdrCustom "EXT") ""- , Header (HdrCustom "Server") (getServerHeaderValue ai)- , Header (HdrCustom "Accept-Ranges") "bytes"- ]--contentHandler :: State -> Socket -> Request String -> [String] -> IO ()-contentHandler (c,mc,ai,s,objects_) conn r gs = do- objects <- readIORef objects_ -- Current snapshot of object tree.- case gs of- [oid] -> do- putStrLn $ printf "Got request for CONTENT for objectId=%s" oid- -- Serve the file which the object maps to.- -- FIXME: Return 404 error code if file has disappeared.- case findByObjectId oid objects of- Just o -> serveStaticFile conn (getHeaders r) mt fp- where - od = getObjectData o- fp = objectFileName od- mt = objectMimeType od- Nothing -> sendErrorResponse conn NotFound []-- _ -> sendErrorResponse conn InternalServerError []----serviceControlHandler :: State -> Socket -> Request String -> [String] -> IO ()-serviceControlHandler (c,mc,ai,s,objects_) conn r gs = do- objects <- readIORef objects_ -- Current snapshot of object tree.- case gs of- [sn] -> do- putStrLn $ printf "Got request for CONTROL for service '%s'" sn- case stringToDeviceType sn of- Just dt -> do- -- Parse the SOAP request- let requestXml = rqBody r- action <- parseControlSoapXml requestXml- -- Deal with the action- case action of- Just a -> do- x <- case a of- ContentDirectoryAction_ cda -> handleCDA dt cda objects- ConnectionManagerAction_ cma -> handleCMA cma- putStrLn $ printf "Response:\n\n%s\n\n" x- sendXmlResponse conn (getExtraHeaders ai) x- Nothing -> - sendErrorResponse conn NotImplemented []- Nothing -> do- putStrLn $ printf "Asked about unknown service '%s'" sn- sendErrorResponse conn NotImplemented []- _ ->- -- Mapped to our URL space, but not parseable? - sendErrorResponse conn NotFound []- where- handleCDA st a objects =- 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.- error "Not implemented"----fallbackHandler :: Socket -> Request String -> [String] -> IO ()-fallbackHandler conn r gs = do- putStrLn "Fallback handler got request:"- print r- sendErrorResponse conn InternalServerError []-- periodicUpdate :: IORef a -> (IO a) -> IO () periodicUpdate a doUpdate = forever $ do@@ -248,14 +57,12 @@ writeIORef a =<< doUpdate -- Atomic replace scanOnce :: String -> IO Objects-scanOnce directory = do +scanOnce directory = do putStrLn $ printf "Scanning directory '%s'" directory objects <- scanDirectory directory putStrLn $ printf "Scanning completed" return objects -- main :: IO () main = niceSocketsDo $ do -- Get the data directory.@@ -269,7 +76,7 @@ let scanOnce' = scanOnce $ rootDirectory c defaultObjects_ <- scanOnce' defaultObjects <- newIORef defaultObjects_- + -- Get the application information. appInfo <- getApplicationInformation @@ -280,19 +87,19 @@ let services = [ ContentDirectoryDevice, ConnectionManagerDevice ] let st = (c,mc,appInfo,services, defaultObjects) - let dispatchTable = - [ (mkRegex "^/description\\.xml$", rootDescriptionHandler st)- , (mkRegex "^/static/(.*)$", staticHandler $ dataDirectory </> "www")- , (mkRegex "^/dynamic/services/([^/]+)/control/?$", serviceControlHandler st)- , (mkRegex "^/content/([0-9a-f,]+)$", contentHandler st)- , (mkRegex "(.*)", fallbackHandler)- ]+ let handlers =+ ifRegex "^/description\\.xml$" (rootDescriptionHandler st) $+ ifRegex "^/static/(.*)$" (staticHandler $ dataDirectory </> "www") $+ ifRegex "^/dynamic/services/ContentDirectory/control/?$" (serviceControlHandler st ContentDirectoryDevice) $+ ifRegex "^/dynamic/services/ConnectionManager/control/?$" (serviceControlHandler st ConnectionManagerDevice) $+ ifRegex "^/content/([0-9a-f,]+)$" (contentHandler st) $+ fallbackHandler -- Start serving. putStrLn "Establishing HTTP server..."- _ <- forkIO $ runHttpServer dispatchTable $ httpServerPort c+ _ <- forkIO $ runHttpServer handlers $ httpServerPort c _ <- putStrLn "Done."- + -- Start broadcasting alive messages. putStrLn "Establishing notification broadcaster..." _ <- forkIO $ sendNotifyForever appInfo c mc
src/Object.hs view
@@ -33,6 +33,7 @@ import Action import Data.Map (Map) import qualified Data.Map as Map+import Data.List (isPrefixOf) import DirectoryUtils import System.FilePath import MimeType@@ -40,8 +41,6 @@ import System.Posix import Text.Printf import StorableExtra-import Text.Regex-import RegexExtra -- Root object id is defined by CD/§2.7.4.2. rootObjectId :: ObjectId@@ -52,11 +51,11 @@ rootObjectParentId = "-1" -- Dispatch table for selecting item type from MIME type.-objectTypeTable :: [(Regex, ObjectType)]-objectTypeTable = [ (mkRegex "^video/.*", ItemVideoMovie)- , (mkRegex "^audio/.*", ItemMusicTrack)- , (mkRegex "^inode/directory$", ContainerStorageFolder)- ]+mimeTypeToObjectType :: String -> Maybe ObjectType+mimeTypeToObjectType s | ("video/" `isPrefixOf` s) = Just ItemVideoMovie+mimeTypeToObjectType s | ("audio/" `isPrefixOf` s) = Just ItemMusicTrack+mimeTypeToObjectType s | ("inode/directory" == s) = Just ContainerStorageFolder+mimeTypeToObjectType _ = Nothing -- An Objects is an abstract data type containing a set of -- objects.@@ -156,9 +155,9 @@ -- Construct object data. let objectData = MkObjectData kp _title fp sz lastModified mimeType -- Add the directory entry to the current accumulator.- return $ case dispatch objectTypeTable mimeType of- Just (objectType,_) -> (oid, (objectType,objectData)) : objects- Nothing -> objects+ return $ case mimeTypeToObjectType mimeType of+ Just objectType -> (oid, (objectType,objectData)) : objects+ Nothing -> objects where round' :: Rational -> Int64 -- Dummy to avoid warning round' = round
− src/RegexExtra.hs
@@ -1,39 +0,0 @@-{-- 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/>.--}--module RegexExtra ( dispatch )- where--import Text.Regex--dispatch :: [(Regex, a)] -> String -> Maybe (a, [String])-dispatch t s = - case findFirst f t of- Nothing -> Nothing- Just (v,gs) -> Just (v, gs)- where- f (r,v) = case matchRegex r s of- Just gs -> Just (v,gs)- Nothing -> Nothing- -findFirst :: (a -> Maybe b) -> [a] -> Maybe b-findFirst _ [] = Nothing-findFirst f (x:xs) =- case f x of- Just v -> Just v- Nothing -> findFirst f xs
src/SendFile.hs view
@@ -16,19 +16,16 @@ 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' +module SendFile ( sendFile ) where -import Data.ByteString as BS (hGet, length)-import Network.Socket.ByteString (sendAll)-import Network.Socket (Socket)+import Data.ByteString (hGet, ByteString)+import qualified Data.ByteString as BS import System.IO (hSeek, withFile, IOMode(..), SeekMode(..)) -sendFile' :: Socket -> FilePath -> Integer -> Integer -> IO ()-sendFile' outs inp off count = do+-- 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)@@ -36,5 +33,5 @@ rsend h reqBytes = do let bytes = min 32768 reqBytes :: Integer buf <- hGet h (fromIntegral bytes)- sendAll outs buf+ output buf rsend h (reqBytes - (fromIntegral $ BS.length buf))
src/Service.hs view
@@ -19,10 +19,10 @@ module Service ( generateDescriptionXml , generateActionResponseXml , DeviceType(..)- , stringToDeviceType+ , deviceTypeToString ) where- -import Text.XML.HXT.Arrow++import Text.XML.HXT.Core import Text.Printf import Configuration import Action@@ -34,9 +34,6 @@ import MimeType import URIExtra -defaultEncodingAttributes :: Attributes-defaultEncodingAttributes = [ (a_output_encoding, utf8) ]- myQuote :: String -> String myQuote = -- TODO: There *must* be a better way to achieve our quoting needs. concatMap f@@ -48,7 +45,7 @@ sanitizeXmlChars :: String -> String-sanitizeXmlChars = +sanitizeXmlChars = map f where f '<' = '_'@@ -65,21 +62,16 @@ data DeviceType = MediaServer | ContentDirectoryDevice | ConnectionManagerDevice- + deviceTypeToString :: DeviceType -> String deviceTypeToString ContentDirectoryDevice = "ContentDirectory" deviceTypeToString ConnectionManagerDevice = "ConnectionManager" deviceTypeToString MediaServer = "MediaServer" -stringToDeviceType :: String -> Maybe DeviceType-stringToDeviceType "ContentDirectory" = Just ContentDirectoryDevice-stringToDeviceType "ConnectionManager" = Just ConnectionManagerDevice-stringToDeviceType _ = Nothing- serviceNs :: ArrowXml a => String -> DeviceType -> a XmlTree XmlTree-serviceNs prefix st = +serviceNs prefix st = sattr an av- where + where an = printf "xmlns:%s" prefix av = printf "urn:schemas-upnp-org:service:%s:1" $ deviceTypeToString st @@ -89,11 +81,11 @@ -- Generate the icon list. generateIconList :: ArrowXml a => Bool -> a XmlTree XmlTree generateIconList False = cmt " omitted device icon list "-generateIconList True = - selem "iconList" +generateIconList True =+ selem "iconList" [ selem "icon" [ selem "mimetype" [ txt $ guessMimeType imageUrl ]- , selem "width" [ txt "240" ] + , selem "width" [ txt "240" ] , selem "height" [ txt "240" ] , selem "url" [ txt imageUrl ] ]@@ -102,21 +94,21 @@ imageUrl = "/static/images/hums.jpg" generateServiceList :: ArrowXml a => [DeviceType] -> a XmlTree XmlTree-generateServiceList services = +generateServiceList services = selem "serviceList" $ map generateService services where generateService service =- selem "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 "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 = +generateDescription c mc services = root [] [ mkelem "root" [sattr "xmlns" "urn:schemas-upnp-org:device-1-0"] [ selem "specVersion"@@ -149,9 +141,9 @@ presentationUrl = "index.html" -- 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))+generateXml :: SysConfigList -> IOSLA (XIOState ()) XmlTree XmlTree -> IO String+generateXml conf a = do+ xml <- runX (a >>> writeDocumentToString (withOutputEncoding utf8 : conf)) return $ concat xml generateDescriptionXml :: Configuration -> MediaServerConfiguration -> [DeviceType] -> IO String@@ -161,7 +153,7 @@ generateResponseXml :: [IOSLA (XIOState ()) XmlTree XmlTree] -> IO String generateResponseXml =- generateXml [(a_output_xml,v_0)] . generateSoapEnvelope+ generateXml [ withOutputPLAIN ] . generateSoapEnvelope generateBrowseResponseXml :: Configuration -> DeviceType -> Objects -> BrowseAction -> IO String @@ -175,7 +167,7 @@ ] ] generateResponseXml body- where + where didl = mkDidl [generateObjectElement cfg os (oid,o)] oid = objectId bps o = findExistingByObjectId oid os -- TODO: Might handle non-existing objects better.@@ -191,7 +183,7 @@ ] ] generateResponseXml body- where + where oid = objectId bps si = startingIndex bps rc = requestedCount bps@@ -216,20 +208,20 @@ generateActionResponseXml _ st _ ContentDirectoryGetSearchCapabilities = generateXml [] $ generateSoapEnvelope body- where + where body = [ mkelem "u:GetSearchCapabilitiesResponse" [ serviceNs "u" st ] [ selem "SearchCaps" [ txt "" ] ] -- No search capabilities (CD/§2.5.18) ] generateActionResponseXml _ st _ ContentDirectoryGetSortCapabilities = generateXml [] $ generateSoapEnvelope body- where + where body = [ mkelem "u:GetSortCapabilitiesResponse" [ serviceNs "u" st ] [ selem "SortCaps" [ txt "" ] ] -- No sorting capabilities (CD/§2.5.19) ] generateSoapEnvelope :: ArrowXml a => [a XmlTree XmlTree] -> a XmlTree XmlTree-generateSoapEnvelope b = +generateSoapEnvelope b = root [] [ mkelem "s:Envelope" [ soapNs, soapEncodingStyle ] [ selem "s:Body" b ]@@ -241,7 +233,7 @@ generateObjectElement :: ArrowXml a => Configuration -> Objects -> (ObjectId, Object) -> a XmlTree XmlTree-generateObjectElement cfg objects (oid, o) = +generateObjectElement cfg objects (oid, o) = mkelem en (as ++ eas) ([ selem "dc:title" [ txt $ sanitizeXmlChars $ objectTitle od ] , selem "upnp:class" [ txt $ getObjectClassName o ]@@ -250,7 +242,7 @@ 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)@@ -266,14 +258,14 @@ -- Generate content URL generateContentUrl :: ArrowXml a => Configuration -> ObjectId -> a XmlTree XmlTree-generateContentUrl cfg oid = +generateContentUrl cfg oid = txt $ show $ mkURI ["content", oid] $ httpServerBase cfg -- Generate any extra elements for any given object. generateExtraElements :: ArrowXml a => Configuration -> (ObjectId, Object) -> [a XmlTree XmlTree] generateExtraElements _ (oid, (Container,_)) = [] generateExtraElements _ (oid, (ContainerStorageFolder,_)) = []-generateExtraElements cfg (oid, (ItemMusicTrack,d)) = +generateExtraElements cfg (oid, (ItemMusicTrack,d)) = [ mkelem "res" [ sattr "protocolInfo" protocolInfo , sattr "size" $ printf "%d" $ objectFileSize d ] -- TODO: should be disabled by Transcoding flag! [ generateContentUrl cfg oid ]@@ -283,7 +275,7 @@ protocolInfo = generateProtocolInfo cfg False mimeType Nothing -- TODO: profileId generateExtraElements cfg (oid, (ItemVideoMovie,d)) =- [ mkelem "res" [ sattr "protocolInfo" protocolInfo + [ mkelem "res" [ sattr "protocolInfo" protocolInfo , sattr "size" $ printf "%d" $ objectFileSize d ] -- TODO: should be disabled by Transcoding flag! [ generateContentUrl cfg oid ] ]@@ -298,7 +290,7 @@ generateProtocolInfo :: Configuration -> Bool -> String -> Maybe String -> String generateProtocolInfo cfg transcode mimeType profileId = protocolPrefix ++ protocolSuffix- where + where playSpeed = 1 :: Int -- DLNA play speed: Normal conversionFlags = -- DLNA conversion flags if transcode then 1 else 0 :: Int@@ -318,10 +310,10 @@ , ("DLNA.ORG_PN", dlnaProfileName cfg) , ("DLNA.ORG_FLAGS" , Just $ printf "%08x%024x" flags (0 :: Int32) ) ] protocolPrefix = "http-get:*:" ++ mimeType ++ ":"- protocolSuffix = + protocolSuffix = if useDlna cfg then join ";" $ mapMaybe (\(n,v) -> mapMaybe1 (printf "%s=%s" n) v) fields- else + else "*" -- Protocol constants. _DLNA_ORG_FLAG_SENDER_PACED = bit 31 :: Int32
src/Soap.hs view
@@ -19,17 +19,9 @@ module Soap ( parseControlSoapXml ) where -import Text.XML.HXT.Arrow+import Text.XML.HXT.Core import Action --- ContentDirectory XML name space-nsContentDirectory :: String-nsContentDirectory = "urn:schemas-upnp-org:service:ContentDirectory:1"---- ConnectionManager XML name space-nsConnectionManager :: String-nsConnectionManager = "urn:schemas-upnp-org:service:ConnectionManager:1"- -- Utility functions for parsing XML. atTag :: ArrowXml a => String -> a XmlTree XmlTree atTag tag = deep (isElem >>> hasLocalPart tag)@@ -42,7 +34,7 @@ textAtTag tag = atTag tag >>> text numberAtTag :: (ArrowXml a, Num b, Read b) => String -> a XmlTree b-numberAtTag tag = +numberAtTag tag = atTag tag >>> text >>> arr read -- Parse the "Browse Flag". CD/§2.5.6@@ -61,9 +53,9 @@ -} parseCDBrowse :: ArrowXml a => a XmlTree ContentDirectoryAction parseCDBrowse =- atTag "Browse" >>> hasNamespaceUri nsContentDirectory >>>+ atTag "Browse" >>> proc l -> do- oid <- textAtTag "ObjectID" + oid <- textAtTag "ObjectID" `orElse` textAtTag "ContainerID" {- XBox-360 -} -< l bf <- parseBrowseFlag -< l flt <- textAtTag "Filter" -< l@@ -72,24 +64,24 @@ sc <- textAtTag "SortCriteria" -< l returnA -< let bps = BrowseParameters oid flt si rq sc in ContentDirectoryBrowse $ bf bps- + parseCDSearchCapabilities :: ArrowXml a => a XmlTree ContentDirectoryAction parseCDSearchCapabilities =- atTag "GetSearchCapabilities" >>> hasNamespaceUri nsContentDirectory >>>+ atTag "GetSearchCapabilities" >>> proc _ -> returnA -< ContentDirectoryGetSearchCapabilities parseCDGetSortCapabilities :: ArrowXml a => a XmlTree ContentDirectoryAction parseCDGetSortCapabilities =- atTag "GetSortCapabilities" >>> hasNamespaceUri nsContentDirectory >>>+ atTag "GetSortCapabilities" >>> proc _ -> returnA -< ContentDirectoryGetSortCapabilities parseCDGetSystemUpdateId :: ArrowXml a => a XmlTree ContentDirectoryAction parseCDGetSystemUpdateId =- atTag "GetSystemUpdateID" >>> hasNamespaceUri nsContentDirectory >>>+ atTag "GetSystemUpdateID" >>> proc _ -> returnA -< ContentDirectoryGetSystemUpdateId parseContentDirectoryQueryXml :: ArrowXml a => a XmlTree Action-parseContentDirectoryQueryXml = +parseContentDirectoryQueryXml = proc l -> do x <- helper -< l returnA -< ContentDirectoryAction_ x@@ -104,28 +96,28 @@ -} parseCMGetProtocolInfo :: ArrowXml a => a XmlTree ConnectionManagerAction-parseCMGetProtocolInfo = - atTag "GetProtocolInfo" >>> hasNamespaceUri nsConnectionManager >>>+parseCMGetProtocolInfo =+ atTag "GetProtocolInfo" >>> proc _ -> returnA -< ConnectionManagerGetProtocolInfo parseCMPrepareForConnection :: ArrowXml a => a XmlTree ConnectionManagerAction-parseCMPrepareForConnection = - atTag "PrepareForConnection" >>> hasNamespaceUri nsConnectionManager >>>+parseCMPrepareForConnection =+ atTag "PrepareForConnection" >>> proc _ -> returnA -< ConnectionManagerPrepareForConnection parseCMConnectionComplete :: ArrowXml a => a XmlTree ConnectionManagerAction-parseCMConnectionComplete = - atTag "ConnectionComplete" >>> hasNamespaceUri nsConnectionManager >>>+parseCMConnectionComplete =+ atTag "ConnectionComplete" >>> proc _ -> returnA -< ConnectionManagerConnectionComplete parseCMGetCurrentConnectionIDs :: ArrowXml a => a XmlTree ConnectionManagerAction-parseCMGetCurrentConnectionIDs = - atTag "GetCurrentConnectionIDs" >>> hasNamespaceUri nsConnectionManager >>>+parseCMGetCurrentConnectionIDs =+ atTag "GetCurrentConnectionIDs" >>> proc _ -> returnA -< ConnectionManagerGetCurrentConnectionIDs parseCMGetCurrentConnectionInfo :: ArrowXml a => a XmlTree ConnectionManagerAction-parseCMGetCurrentConnectionInfo = - atTag "GetCurrentConnectionInfo" >>> hasNamespaceUri nsConnectionManager >>>+parseCMGetCurrentConnectionInfo =+ atTag "GetCurrentConnectionInfo" >>> proc _ -> returnA -< ConnectionManagerGetCurrentConnectionInfo parseConnectionManagerQueryXml :: ArrowXml a => a XmlTree Action@@ -140,7 +132,7 @@ `orElse` parseCMGetCurrentConnectionInfo parseQueryXml :: ArrowXml a => a XmlTree Action-parseQueryXml = +parseQueryXml = parseContentDirectoryQueryXml `orElse` parseConnectionManagerQueryXml {-@@ -149,15 +141,15 @@ -} -- parseControlSoapXml :: String -> IO (Maybe Action) parseControlSoapXml xml = do- as <- runX $ readString inAttributes xml >>> parseQueryXml+ as <- runX $ readString conf xml >>> parseQueryXml case as of (a:_) -> return $ Just a _ -> return $ Nothing where- inAttributes = [ (a_validate, v_0)- , (a_check_namespaces, v_1) - ]+ conf :: SysConfigList+ conf = [ withValidate no+ , withCheckNamespaces False+ , withTrace 3+ ]