hums 0.3.2 → 0.3.3
raw patch · 13 files changed
+197/−449 lines, 13 filesdep +blaze-builderdep +case-insensitivedep +enumeratordep −HTTPdep −hashmapdep ~text
Dependencies added: blaze-builder, case-insensitive, enumerator, http-types, unordered-containers, wai, warp
Dependencies removed: HTTP, hashmap
Dependency ranges changed: text
Files
- hums.cabal +13/−9
- src/Action.hs +3/−1
- src/Configuration.hs +1/−2
- src/Handlers.hs +101/−97
- src/HttpMonad.hs +0/−175
- src/HttpServer.hs +0/−67
- src/Main.hs +54/−40
- src/MimeType.hs +4/−1
- src/Object.hs +9/−10
- src/SendFile.hs +0/−37
- src/Service.hs +8/−7
- src/SimpleServiceDiscoveryProtocol.hs +2/−2
- src/Soap.hs +2/−1
hums.cabal view
@@ -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
src/Action.hs view
@@ -24,7 +24,9 @@ , ObjectId ) where -type ObjectId = String+import Data.ByteString (ByteString)++type ObjectId = ByteString data BrowseParameters = BrowseParameters { objectId :: ObjectId
src/Configuration.hs view
@@ -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.
src/Handlers.hs view
@@ -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"+
− src/HttpMonad.hs
@@ -1,175 +0,0 @@-{-- hums - The Haskell UPnP Server- Copyright (C) 2009-2010 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 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
− src/HttpServer.hs
@@ -1,67 +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 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
src/Main.hs view
@@ -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 ()
src/MimeType.hs view
@@ -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"
src/Object.hs view
@@ -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
− src/SendFile.hs
@@ -1,37 +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 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))
src/Service.hs view
@@ -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.
src/SimpleServiceDiscoveryProtocol.hs view
@@ -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
src/Soap.hs view
@@ -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