diff --git a/hums.cabal b/hums.cabal --- a/hums.cabal +++ b/hums.cabal @@ -1,5 +1,5 @@ Name: hums -Version: 0.4.3 +Version: 0.5.0 Synopsis: Haskell UPnP Media Server Description: A simple UPnP Media Server. . @@ -28,15 +28,17 @@ , filepath >= 1.1.0.0 , HaXml >= 1.22 && <1.23 , http-types >= 0.7 && <0.8 - , hxt >= 9.1 && < 9.2 + , hxt >= 9.1 && < 9.4 , MissingH >= 1.0.1 - , mtl == 2.0.* - , network >= 2.3 && < 2.4 + , mtl >= 2.1 + , network >= 2.3 && < 2.5 , parsec >= 3.0 && < 3.2 , system-uuid >= 2.1 && < 2.2 + , system-filepath >= 0.4.7 && < 0.5 + , system-fileio >= 0.3.10 && < 0.4 , text >= 0.11 && < 0.12 - , transformers >= 0.2 && < 0.3 - , unix >= 2.3.0.0 + , transformers >= 0.3 + , unix >= 2.5.0.0 , unordered-containers >= 0.2 && < 0.3 , case-insensitive >= 0.4 && < 0.5 , wai >= 1.3 && < 1.4 diff --git a/src/Configuration.hs b/src/Configuration.hs --- a/src/Configuration.hs +++ b/src/Configuration.hs @@ -1,6 +1,6 @@ {- hums - The Haskell UPnP Server - Copyright (C) 2009 Bardur Arantsson + Copyright (C) 2009, 2012 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 @@ -24,13 +24,16 @@ , parseConfiguration ) where -import System.Posix.Unistd (SystemID(..), getSystemID) -import Text.Printf -import Network.URI (URI, parseURI) -import Data.ConfigFile -import Control.Monad.Error -import Data.Either.Utils -import Data.Maybe +import Control.Monad.Error +import Data.ConfigFile +import Data.Either.Utils +import Data.Maybe +import Filesystem.Path (FilePath) +import Filesystem.Path.CurrentOS (decodeString, encodeString) +import Network.URI (URI, parseURI) +import Prelude hiding (FilePath) +import System.Posix.Unistd (SystemID(..), getSystemID) +import Text.Printf {- @@ -45,7 +48,7 @@ , enableDeviceIcon :: Bool , useDlna :: Bool , dlnaProfileName :: Maybe String -- Only used when useDlna is available. - , rootDirectory :: String + , rootDirectory :: FilePath } deriving (Show) @@ -96,10 +99,10 @@ getServerHeaderValue (ApplicationInformation on ov an av) = printf "%s/%s, UPnP/1.0, %s/%s" on ov an av -parseConfiguration :: ConfigParser -> String -> IO Configuration +parseConfiguration :: ConfigParser -> FilePath -> IO Configuration parseConfiguration cp0 cfname = do cfg <- runErrorT $ do - cf <- join $ liftIO $ readfile cp0 cfname + cf <- join $ liftIO $ readfile cp0 (encodeString cfname) ip <- get cf networkSection "listen_ip" port <- get cf networkSection "listen_port" rootDirectory_ <- get cf defaultSection "root_directory" @@ -110,7 +113,7 @@ , enableDeviceIcon = True , useDlna = True , dlnaProfileName = Nothing - , rootDirectory = rootDirectory_ } + , rootDirectory = decodeString rootDirectory_ } return $ forceEither cfg where defaultSection = "DEFAULT" diff --git a/src/DirectoryUtils.hs b/src/DirectoryUtils.hs --- a/src/DirectoryUtils.hs +++ b/src/DirectoryUtils.hs @@ -1,6 +1,6 @@ {- hums - The Haskell UPnP Server - Copyright (C) 2009 Bardur Arantsson + Copyright (C) 2009, 2012 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 @@ -19,51 +19,52 @@ module DirectoryUtils ( walkTree ) where -import Control.Exception (catch, SomeException) -import Control.Monad -import Data.List -import Prelude hiding (catch) -import System.Directory -import System.FilePath +import Control.Exception (catch, SomeException) +import Control.Monad +import Data.List +import qualified Data.Text as T +import Filesystem (listDirectory) +import Filesystem.Path (FilePath, filename) +import Filesystem.Path.CurrentOS (toText, encode) +import Prelude hiding (FilePath) +import System.Posix.ByteString (FileStatus) +import qualified System.Posix.ByteString as P +-- Sorting function. +compareNames :: FilePath -> FilePath -> Ordering +compareNames a b = compare (f a) (f b) where + f = T.toCaseFold . either id id . toText . filename + -- Performs a pre-order traversal of a directory. -- It calls f a0 a fp for each file/directory, where -- a0 is the accumulator as it appeared at the start -- of iteration of the parent directory, a is the -- current value of the accumulator and fp is the -- file name of the file/directory being visited. -walkTree :: a -> (a -> a -> FilePath -> IO a) -> FilePath -> IO a +walkTree :: a -> (a -> a -> FileStatus -> FilePath -> IO a) -> FilePath -> IO a walkTree s0 f d = do -- FIXME: Need to detect loops! -- Get files and directories in directory. If that fails -- we just pretend there are none. allNames <- catch - (getDirectoryContents d) + (listDirectory d) (\(e :: SomeException) -> 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. - let fullNames = map (combine d) names + -- Sort + let sortedNames = sortBy compareNames allNames -- Traverse subdirectories and return accumulator. - foldM traverse s0 fullNames + foldM traverse s0 sortedNames where traverse s n = do - 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 + st <- P.getFileStatus $ encode n + if P.isRegularFile st + then f s0 s st n + else if P.isDirectory st + then do + s' <- f s0 s st n + walkTree s' f n + else 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 - isSpecialDirectory _ = False diff --git a/src/Handlers.hs b/src/Handlers.hs --- a/src/Handlers.hs +++ b/src/Handlers.hs @@ -1,6 +1,6 @@ {- hums - The Haskell UPnP Server - Copyright (C) 2009 Bardur Arantsson + Copyright (C) 2009, 2012 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 @@ -43,8 +43,10 @@ import Network.HTTP.Types (Status, Header, partialContent206, forbidden403, notImplemented501, ok200, notFound404) import Network.HTTP.Types.Header (hConnection, hContentLength, hContentType) import Network.Wai (Application, Request, Response(..), requestBody, requestHeaders, responseLBS) -import System.FilePath -import System.IO (withFile, hFileSize, IOMode(..)) +import Filesystem.Path (FilePath, ()) +import Filesystem.Path.CurrentOS (encodeString, fromText) +import qualified Filesystem as FS +import Prelude hiding (FilePath) import Text.Printf (printf) import Soap @@ -70,26 +72,24 @@ -} -fileSize :: FilePath -> IO Integer -fileSize fp = - withFile fp ReadMode $ \h -> hFileSize h - serveStaticFile :: Request -> ByteString -> FilePath -> ResourceT IO Response serveStaticFile req mimeType fp = do - logMessage $ printf "Serving file '%s'..." fp + logMessage $ printf "Serving file '%s'..." $ sfp -- Do we have a range header? let ranges = case lookup rangeHeader $ requestHeaders req of Just value -> parseRangeHeader $ B8.unpack value Nothing -> [(Nothing, Nothing)] -- whole file -- Serve the ranges. - fsz <- lift $ fileSize fp + fsz <- lift $ FS.getSize fp serveFile fsz ranges where + sfp = encodeString fp + serveFile fsz [(l,h)] = do let l' = maybe 0 id l let h' = maybe (fsz-1) id h let n = (h' - l' + 1) - let src = (sourceFileRange fp (Just l') (Just n)) $= + let src = (sourceFileRange sfp (Just l') (Just n)) $= (CL.map $ Chunk . fromByteString) return $ ResponseSource partialContent206 [ hdrContentLength n @@ -114,7 +114,7 @@ ] xml -- Handle static files. -staticHandler :: Request -> String -> [Text] -> ResourceT IO Response +staticHandler :: Request -> FilePath -> [Text] -> ResourceT IO Response staticHandler req root path = do logMessage $ "Got request for static content: " ++ (show path) if dotDot `elem` path then -- Reject relative URLs. @@ -122,7 +122,7 @@ else serveStaticFile req mimeType fp where - fp = foldl () root (map T.unpack path) + fp = foldl () root (map fromText path) mimeType = guessMimeType fp dotDot = ".." diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,6 +1,6 @@ {- hums - The Haskell UPnP Server - Copyright (C) 2009 Bardur Arantsson + Copyright (C) 2009,2012 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 @@ -23,8 +23,13 @@ import Data.UUID () import Network.Utils import Network.Wai (Application, Request(..)) -import Network.Wai.Handler.Warp (run) -import System.FilePath +import Network.Wai.Handler.Warp (runSettings, + defaultSettings, + settingsTimeout, + settingsPort) +import Filesystem.Path (FilePath, ()) +import Filesystem.Path.CurrentOS (decodeString, encodeString) +import Prelude hiding (FilePath) import qualified System.UUID.V4 as U import Text.Printf @@ -55,20 +60,20 @@ threadDelay 120000000 -- Every 120 seconds should be more than enough. writeIORef a =<< doUpdate -- Atomic replace -scanOnce :: String -> IO Objects +scanOnce :: FilePath -> IO Objects scanOnce directory = do - putStrLn $ printf "Scanning directory '%s'" directory + putStrLn $ printf "Scanning directory '%s'" $ encodeString directory objects <- scanDirectory directory putStrLn $ printf "Scanning completed" return objects -application :: State -> String -> Application +application :: State -> FilePath -> Application application state dataDirectory request = do case pathInfo request of ["description.xml"] -> rootDescriptionHandler state ("static" : path) -> - staticHandler request (dataDirectory "www") path + staticHandler request (dataDirectory staticDir) path ("dynamic" : "services" : "ContentDirectory" : "control" : _) -> serviceControlHandler state ContentDirectoryDevice request ("dynamic" : "services" : "ConnectionManager" : "control" : _) -> @@ -77,15 +82,17 @@ contentHandler request state objectId _ -> fallbackHandler + where + staticDir = decodeString "www" main :: IO () main = niceSocketsDo $ do -- Get the data directory. - dataDirectory <- getDataFileName "." + dataDirectory <- fmap decodeString $ getDataFileName "." -- Parse configuration. - c <- parseConfiguration emptyCP $ dataDirectory "hums.cfg" + c <- parseConfiguration emptyCP $ dataDirectory (decodeString "hums.cfg") print c -- Scan objects once at the start. @@ -105,7 +112,11 @@ -- Start serving. putStrLn "Establishing HTTP server..." - _ <- forkIO $ run (httpServerPort c) (application st dataDirectory) + _ <- forkIO $ do + let settings = defaultSettings { settingsPort = (httpServerPort c) + , settingsTimeout = 86400 + } + runSettings settings (application st dataDirectory) _ <- putStrLn "Done." -- Start broadcasting alive messages. diff --git a/src/MimeType.hs b/src/MimeType.hs --- a/src/MimeType.hs +++ b/src/MimeType.hs @@ -1,6 +1,6 @@ {- hums - The Haskell UPnP Server - Copyright (C) 2009 Bardur Arantsson + Copyright (C) 2009, 2012 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 @@ -17,26 +17,36 @@ -} module MimeType ( guessMimeType + , imageJpeg ) where import Data.ByteString (ByteString) import Data.ByteString.Char8 () -import System.FilePath +import Data.Text (Text) +import Filesystem.Path (FilePath, extension) +import Prelude hiding (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 -> ByteString guessMimeType fp = - mimeType $ takeExtension fp + case extension fp of + Nothing -> defaultMimeType + Just ext -> mimeType ext where - mimeType :: String -> ByteString - mimeType ".xml" = "text/xml" - mimeType ".avi" = "video/divx" -- PlayStation 3 oddity ('x-msvideo' is standard) - mimeType ".mp3" = "audio/mpeg" - mimeType ".mpg" = "video/mpeg" - mimeType ".m2ts" = "video/mpeg" - mimeType ".m2t" = "video/mpeg" - mimeType ".jpg" = "image/jpeg" - mimeType ".mp4" = "video/mp4" - mimeType _ = "application/octet-stream" -- Reasonable default + mimeType :: Text -> ByteString + mimeType "xml" = "text/xml" + mimeType "avi" = "video/divx" -- PlayStation 3 oddity ('x-msvideo' is standard) + mimeType "mp3" = "audio/mpeg" + mimeType "mpg" = "video/mpeg" + mimeType "m2ts" = "video/mpeg" + mimeType "m2t" = "video/mpeg" + mimeType "jpg" = imageJpeg + mimeType "mp4" = "video/mp4" + mimeType _ = defaultMimeType + defaultMimeType = "application/octet-stream" + +-- JPEG image mime type +imageJpeg :: ByteString +imageJpeg = "image/jpeg" diff --git a/src/Object.hs b/src/Object.hs --- a/src/Object.hs +++ b/src/Object.hs @@ -1,6 +1,6 @@ {- hums - The Haskell UPnP Server - Copyright (C) 2009 Bardur Arantsson + Copyright (C) 2009, 2012 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 @@ -32,13 +32,18 @@ import Action import Data.ByteString (ByteString, isPrefixOf) -import Data.Char (isAscii) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as H import qualified Data.Text as T import Data.Int -import System.FilePath -import System.Posix +import Data.Word (Word8) +import Filesystem.Path (FilePath, dropExtension, filename) +import Filesystem.Path.CurrentOS (encode) +import Prelude hiding (FilePath) +import System.Posix.ByteString (FileStatus) +import qualified System.Posix.ByteString as P import Text.Printf import DirectoryUtils @@ -132,8 +137,8 @@ Nothing -> error $ printf "Couldn't find object '%s'" $ T.unpack oid -- Accumulator function for building the basic list of files/directories. -scanFile :: [(ObjectId, Object)] -> [(ObjectId, Object)] -> FilePath -> IO [(ObjectId, Object)] -scanFile parentObjects objects fp = do +scanFile :: [(ObjectId, Object)] -> [(ObjectId, Object)] -> FileStatus -> FilePath -> IO [(ObjectId, Object)] +scanFile parentObjects objects st fp = do -- Find parent's object Id. let kp = case parentObjects of [] -> rootObjectId @@ -141,19 +146,18 @@ -- Compute object id for the directory entry. -- FIXME: Should handle 'file gone missing' -- simply don't prepend an -- object in that case. - st <- getFileStatus fp - deviceId <- toHexString $ deviceID st - fileId <- toHexString $ fileID st + deviceId <- toHexString $ P.deviceID st + fileId <- toHexString $ P.fileID st let oid = T.pack $ printf "%s,%s" deviceId fileId -- Compute the update ID. - let lastModified = round' $ toRational $ modificationTime st + let lastModified = round' $ toRational $ P.modificationTime st -- Compute file size. - let sz = (fromIntegral . System.Posix.fileSize) st + let sz = (fromIntegral . P.fileSize) st -- Compute object title. - let mapExt = if isDirectory st then id else dropExtension - _title = map replaceNonAscii $ mapExt $ takeFileName fp + let mapExt = if P.isDirectory st then id else dropExtension + _title = B8.unpack $ B.map replaceNonAscii $ encode $ mapExt $ filename fp -- Start by guessing mime type. - let mimeType = if isDirectory st then + let mimeType = if P.isDirectory st then "inode/directory" -- Directories are special. else guessMimeType fp -- Construct object data. @@ -165,10 +169,10 @@ where round' :: Rational -> Int64 -- Dummy to avoid warning round' = round - -- Replace non-ASCII characters to work around encoding issues. - replaceNonAscii :: Char -> Char - replaceNonAscii c | isAscii c = c - replaceNonAscii _ = '?' + -- Replace non-printable characters to work around encoding issues. + replaceNonAscii :: Word8 -> Word8 + replaceNonAscii c | (c >= 0x20) && (c <= 0x7E) = c + replaceNonAscii _ = 0x3F -- Function for building the Object tree structure. scanDirectory :: FilePath -> IO Objects diff --git a/src/Service.hs b/src/Service.hs --- a/src/Service.hs +++ b/src/Service.hs @@ -1,6 +1,6 @@ {- hums - The Haskell UPnP Server - Copyright (C) 2009 Bardur Arantsson + Copyright (C) 2009, 2012 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 @@ -120,7 +120,7 @@ generateIconList True = (simpleElement "iconList" [ simpleElement "icon" - [ textElement "mimetype" $ B8.unpack $ guessMimeType imageUrl + [ textElement "mimetype" imageMimeType , textElement "width" "240" , textElement "height" "240" , textElement "url" imageUrl @@ -128,6 +128,7 @@ ]) where imageUrl = "/static/images/hums.jpg" + imageMimeType = B8.unpack imageJpeg generateServiceList :: [DeviceType] -> Content () generateServiceList services =