hums 0.3.0 → 0.3.1
raw patch · 12 files changed
+54/−54 lines, 12 files
Files
- hums.cabal +1/−1
- src/Configuration.hs +11/−11
- src/Didl.hs +1/−1
- src/DirectoryUtils.hs +6/−6
- src/HttpExtra.hs +4/−4
- src/HttpMonad.hs +4/−4
- src/MimeType.hs +2/−2
- src/Object.hs +17/−12
- src/Service.hs +1/−6
- src/SimpleServiceDiscoveryProtocol.hs +3/−3
- src/StorableExtra.hs +2/−2
- src/URIExtra.hs +2/−2
hums.cabal view
@@ -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. .
src/Configuration.hs view
@@ -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
src/Didl.hs view
@@ -16,7 +16,7 @@ along with this program. If not, see <http://www.gnu.org/licenses/>. -} -module Didl ( mkDidl +module Didl ( mkDidl ) where import Text.XML.HXT.Arrow
src/DirectoryUtils.hs view
@@ -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
src/HttpExtra.hs view
@@ -16,7 +16,7 @@ along with this program. If not, see <http://www.gnu.org/licenses/>. -} -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 '-'
src/HttpMonad.hs view
@@ -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
src/MimeType.hs view
@@ -16,7 +16,7 @@ along with this program. If not, see <http://www.gnu.org/licenses/>. -} -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"
src/Object.hs view
@@ -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"
src/Service.hs view
@@ -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
src/SimpleServiceDiscoveryProtocol.hs view
@@ -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 ()
src/StorableExtra.hs view
@@ -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
src/URIExtra.hs view
@@ -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)