diff --git a/hums.cabal b/hums.cabal
--- a/hums.cabal
+++ b/hums.cabal
@@ -1,5 +1,5 @@
Name: hums
-Version: 0.3.0
+Version: 0.3.1
Synopsis: Haskell UPnP Media Server
Description: A simple UPnP Media Server.
.
diff --git a/src/Configuration.hs b/src/Configuration.hs
--- a/src/Configuration.hs
+++ b/src/Configuration.hs
@@ -39,24 +39,24 @@
-}
-data Configuration =
+data Configuration =
Configuration { localNetIp :: String
, httpServerBase :: URI
, httpServerPort :: Word16
, enableDeviceIcon :: Bool
, useDlna :: Bool
, dlnaProfileName :: Maybe String -- Only used when useDlna is available.
- , rootDirectory :: String
+ , rootDirectory :: String
}
deriving (Show)
{-
- Media Server Configuration
+ Media Server Configuration
-}
-data MediaServerConfiguration = MediaServerConfiguration
+data MediaServerConfiguration = MediaServerConfiguration
{ uuid :: String
, friendlyName :: String
, manufacturer :: String
@@ -75,26 +75,26 @@
-}
-data ApplicationInformation = ApplicationInformation
+data ApplicationInformation = ApplicationInformation
{ operatingSystemName :: String
, operatingSystemVersion :: String
, applicationName :: String
- , applicationVersion :: String
+ , applicationVersion :: String
}
-getApplicationInformation :: IO ApplicationInformation
+getApplicationInformation :: IO ApplicationInformation
getApplicationInformation = do
systemId <- getSystemID
- return ApplicationInformation
- { operatingSystemName = systemName systemId
+ return ApplicationInformation
+ { operatingSystemName = systemName systemId
, operatingSystemVersion = release systemId
, applicationName = "hums"
, applicationVersion = "0"
}
getServerHeaderValue :: ApplicationInformation -> String
-getServerHeaderValue (ApplicationInformation on ov an av) =
+getServerHeaderValue (ApplicationInformation on ov an av) =
printf "%s/%s, UPnP/1.0, %s/%s" on ov an av
parseConfiguration :: ConfigParser -> String -> IO Configuration
@@ -104,7 +104,7 @@
ip <- get cf networkSection "listen_ip"
port <- get cf networkSection "listen_port"
rootDirectory_ <- get cf defaultSection "root_directory"
- return Configuration
+ return Configuration
{ localNetIp = ip
, httpServerPort = port
, httpServerBase = fromJust $ parseURI $ printf "http://%s:%d" ip port
diff --git a/src/Didl.hs b/src/Didl.hs
--- a/src/Didl.hs
+++ b/src/Didl.hs
@@ -16,7 +16,7 @@
along with this program. If not, see .
-}
-module Didl ( mkDidl
+module Didl ( mkDidl
) where
import Text.XML.HXT.Arrow
diff --git a/src/DirectoryUtils.hs b/src/DirectoryUtils.hs
--- a/src/DirectoryUtils.hs
+++ b/src/DirectoryUtils.hs
@@ -27,16 +27,16 @@
-- 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
+-- 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 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)
+ allNames <- catch
+ (getDirectoryContents d)
(\e -> do
putStrLn $ "Error retrieving directory contents: " ++ show e -- Log errors
return [])
@@ -46,7 +46,7 @@
let fullNames = map (combine d) names
-- Traverse subdirectories and return accumulator.
foldM traverse s0 fullNames
- where
+ where
traverse s n = do
isFile <- doesFileExist n
case isFile of
@@ -54,7 +54,7 @@
False -> do
isDirectory <- doesDirectoryExist n
case isDirectory of
- True -> do
+ True -> do
s' <- f s0 s n
walkTree s' f n
False -> do
diff --git a/src/HttpExtra.hs b/src/HttpExtra.hs
--- a/src/HttpExtra.hs
+++ b/src/HttpExtra.hs
@@ -16,7 +16,7 @@
along with this program. If not, see .
-}
-module HttpExtra ( parseRangeHeader
+module HttpExtra ( parseRangeHeader
) where
import Text.ParserCombinators.Parsec
@@ -24,16 +24,16 @@
parseRange :: GenParser Char a (Maybe Integer, Maybe Integer)
parseRange =
choice [parseFullRange,
- parseEndRange,
+ parseEndRange,
parseSingleByteRange]
-
+
parseFullRange :: GenParser Char a (Maybe Integer, Maybe Integer)
parseFullRange = do
i1 <- parseInteger
_ <- char '-'
i2 <- optionMaybe parseInteger
return (Just i1, i2)
-
+
parseEndRange :: GenParser Char a (Maybe Integer, Maybe Integer)
parseEndRange = do
_ <- char '-'
diff --git a/src/HttpMonad.hs b/src/HttpMonad.hs
--- a/src/HttpMonad.hs
+++ b/src/HttpMonad.hs
@@ -45,10 +45,10 @@
-- State of the HTTP writer monad.
data HttpState =
HttpState { hHeaders :: [Header]
- , hHeadersFlushed :: Bool
- , hStatusCode :: HttpResponseCode
- , hOutput :: ByteString -> IO ()
- }
+ , hHeadersFlushed :: Bool
+ , hStatusCode :: HttpResponseCode
+ , hOutput :: ByteString -> IO ()
+ }
type Req = Request String
diff --git a/src/MimeType.hs b/src/MimeType.hs
--- a/src/MimeType.hs
+++ b/src/MimeType.hs
@@ -16,7 +16,7 @@
along with this program. If not, see .
-}
-module MimeType ( guessMimeType
+module MimeType ( guessMimeType
) where
import System.FilePath
@@ -27,7 +27,7 @@
guessMimeType :: FilePath -> String
guessMimeType fp =
mimeType $ takeExtension fp
- where
+ where
mimeType ".xml" = "text/xml"
mimeType ".avi" = "video/divx" -- PlayStation 3 oddity ('x-msvideo' is standard)
mimeType ".mp3" = "audio/mpeg"
diff --git a/src/Object.hs b/src/Object.hs
--- a/src/Object.hs
+++ b/src/Object.hs
@@ -31,6 +31,7 @@
) where
import Action
+import Data.Char (isAscii)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.List (isPrefixOf)
@@ -59,7 +60,7 @@
-- An Objects is an abstract data type containing a set of
-- objects.
-data Objects = Objects
+data Objects = Objects
{ mapIdToObject :: Map ObjectId Object
, mapParentToChildren :: Map ObjectId [ObjectId]
, systemUpdateId :: Int64
@@ -67,7 +68,7 @@
deriving (Show)
-- Object data which applies for all objects.
-data ObjectData = MkObjectData
+data ObjectData = MkObjectData
{ objectParentId :: ObjectId -- Object ID of parent object.
, objectTitle :: String -- Title of the object.
, objectFileName :: FilePath -- Physical file.
@@ -83,7 +84,7 @@
| ItemMusicTrack
| ItemVideoMovie
deriving (Show)
-
+
-- We can serve different types of objects.
type Object = (ObjectType, ObjectData)
@@ -136,9 +137,9 @@
[] -> rootObjectId
((oid,_):_) -> oid
-- Compute object id for the directory entry.
- -- FIXME: Should handle 'file gone missing' -- simply don't prepend an
+ -- FIXME: Should handle 'file gone missing' -- simply don't prepend an
-- object in that case.
- st <- getFileStatus fp
+ st <- getFileStatus fp
deviceId <- toHexString $ deviceID st
fileId <- toHexString $ fileID st
let oid = printf "%s,%s" deviceId fileId
@@ -146,8 +147,9 @@
let lastModified = round' $ toRational $ modificationTime st
-- Compute file size.
let sz = (fromIntegral . System.Posix.fileSize) st
- -- Compute misc. attributes.
- let _title = dropExtension $ takeFileName fp
+ -- Compute object title.
+ let mapExt = if isDirectory st then id else dropExtension
+ _title = map replaceNonAscii $ mapExt $ takeFileName fp
-- Start by guessing mime type.
let mimeType = if isDirectory st then
"inode/directory" -- Directories are special.
@@ -161,8 +163,11 @@
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 _ = '?'
-
-- Function for building the Object tree structure.
scanDirectory :: FilePath -> IO Objects
scanDirectory d = do
@@ -174,15 +179,15 @@
let getModificationTime = objectLastModified . getObjectData . snd
- return Objects
+ return Objects
{ mapIdToObject = Map.fromList o'
, mapParentToChildren = mapParentToChildrenX
, systemUpdateId = maximum $ map getModificationTime o'
}
- where
+ where
-- The root object is fixed.
- rootObject =
- (rootObjectId,
+ rootObject =
+ (rootObjectId,
(Container, MkObjectData { objectParentId = rootObjectParentId
, objectTitle = "root"
, objectFileName = "root"
diff --git a/src/Service.hs b/src/Service.hs
--- a/src/Service.hs
+++ b/src/Service.hs
@@ -42,18 +42,13 @@
f '>' = ">"
f c = [c]
-
-
sanitizeXmlChars :: String -> String
-sanitizeXmlChars =
- map f
+sanitizeXmlChars = map f
where
f '<' = '_'
f '>' = '_'
f '&' = '_'
f c = c
-
-
optSelem :: ArrowXml a => String -> Maybe String -> a n XmlTree
optSelem n Nothing = cmt $ printf " %s omitted " n
diff --git a/src/SimpleServiceDiscoveryProtocol.hs b/src/SimpleServiceDiscoveryProtocol.hs
--- a/src/SimpleServiceDiscoveryProtocol.hs
+++ b/src/SimpleServiceDiscoveryProtocol.hs
@@ -19,7 +19,7 @@
module SimpleServiceDiscoveryProtocol ( sendNotifyForever
, MessageType(..)
)
- where
+ where
import Configuration
import Network.Socket
@@ -36,7 +36,7 @@
| MediaServerNotification
generateNotifyAlive :: ApplicationInformation -> Configuration -> MediaServerConfiguration -> MessageType -> String
-generateNotifyAlive ai c msc messageType =
+generateNotifyAlive ai c msc messageType =
concat [ printf "NOTIFY * HTTP/1.1\r\n"
, printf "HOST: 239.255.255.250:1900\r\n"
, printf "CACHE-CONTROL: max-age=180\r\n"
@@ -70,7 +70,7 @@
return ()
sendNotifyAlive :: ApplicationInformation -> Configuration -> MediaServerConfiguration -> MessageType -> IO ()
-sendNotifyAlive ai c msc =
+sendNotifyAlive ai c msc =
sendRawMessage c . generateNotifyAlive ai c msc
sendNotifyAliveAll :: ApplicationInformation -> Configuration -> MediaServerConfiguration -> IO ()
diff --git a/src/StorableExtra.hs b/src/StorableExtra.hs
--- a/src/StorableExtra.hs
+++ b/src/StorableExtra.hs
@@ -35,11 +35,11 @@
return (x : xs)
else
return []
-
+
-- Convert a storable to a string of hex digits.
toHexString :: Storable a => a -> IO String
toHexString a = do
bytes <- toWord8Array a
- let s = concatMap (printf "%02x") bytes :: String
+ let s = concatMap (printf "%02x") bytes :: String
return s
diff --git a/src/URIExtra.hs b/src/URIExtra.hs
--- a/src/URIExtra.hs
+++ b/src/URIExtra.hs
@@ -33,7 +33,7 @@
Just u -> u
Nothing -> error $ "Invalid URI component '" ++ s ++ "'"
--- Make sure we have a trailing slash on all path components,
+-- Make sure we have a trailing slash on all path components,
-- *except* the last.
addSlashes :: [String] -> [String]
addSlashes [] = []
@@ -52,5 +52,5 @@
mkURI' u $ map mkURIReference $ addSlashes ss
mkURI' :: URI -> [URI] -> URI
-mkURI' =
+mkURI' =
foldl (\a r -> fromJust $ r `relativeTo` a)