hums 0.4.3 → 0.5.0
raw patch · 8 files changed
+133/−101 lines, 8 filesdep +system-fileiodep +system-filepathdep ~hxtdep ~mtldep ~network
Dependencies added: system-fileio, system-filepath
Dependency ranges changed: hxt, mtl, network, transformers, unix
Files
- hums.cabal +8/−6
- src/Configuration.hs +15/−12
- src/DirectoryUtils.hs +29/−28
- src/Handlers.hs +12/−12
- src/Main.hs +21/−10
- src/MimeType.hs +23/−13
- src/Object.hs +22/−18
- src/Service.hs +3/−2
hums.cabal view
@@ -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
src/Configuration.hs view
@@ -1,6 +1,6 @@ {- hums - The Haskell UPnP Server- Copyright (C) 2009 Bardur Arantsson <bardur@scientician.net>+ Copyright (C) 2009, 2012 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@@ -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"
src/DirectoryUtils.hs view
@@ -1,6 +1,6 @@ {- hums - The Haskell UPnP Server- Copyright (C) 2009 Bardur Arantsson <bardur@scientician.net>+ Copyright (C) 2009, 2012 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@@ -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
src/Handlers.hs view
@@ -1,6 +1,6 @@ {- hums - The Haskell UPnP Server- Copyright (C) 2009 Bardur Arantsson <bardur@scientician.net>+ Copyright (C) 2009, 2012 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@@ -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 = ".."
src/Main.hs view
@@ -1,6 +1,6 @@ {- hums - The Haskell UPnP Server- Copyright (C) 2009 Bardur Arantsson <bardur@scientician.net>+ Copyright (C) 2009,2012 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@@ -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.
src/MimeType.hs view
@@ -1,6 +1,6 @@ {- hums - The Haskell UPnP Server- Copyright (C) 2009 Bardur Arantsson <bardur@scientician.net>+ Copyright (C) 2009, 2012 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@@ -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"
src/Object.hs view
@@ -1,6 +1,6 @@ {- hums - The Haskell UPnP Server- Copyright (C) 2009 Bardur Arantsson <bardur@scientician.net>+ Copyright (C) 2009, 2012 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@@ -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
src/Service.hs view
@@ -1,6 +1,6 @@ {- hums - The Haskell UPnP Server- Copyright (C) 2009 Bardur Arantsson <bardur@scientician.net>+ Copyright (C) 2009, 2012 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@@ -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 =