hums 0.6.0 → 0.7.0
raw patch · 7 files changed
+86/−108 lines, 7 filesdep −conduitdep −conduit-extradep −parsecdep ~waidep ~warp
Dependencies removed: conduit, conduit-extra, parsec
Dependency ranges changed: wai, warp
Files
- hums.cabal +3/−7
- src/DirectoryUtils.hs +2/−3
- src/Handlers.hs +44/−46
- src/HttpExtra.hs +24/−40
- src/Main.hs +9/−7
- src/Object.hs +2/−3
- src/URIExtra.hs +2/−2
hums.cabal view
@@ -1,5 +1,5 @@ Name: hums-Version: 0.6.0+Version: 0.7.0 Synopsis: Haskell UPnP Media Server Description: A simple UPnP Media Server. .@@ -21,8 +21,6 @@ Build-Depends: base == 4.* , blaze-builder >= 0.3 && <0.4 , bytestring >= 0.9.0.1- , conduit >= 1.1 && <2- , conduit-extra >= 1.1 && <2 , ConfigFile >= 1.0.5 , containers >= 0.1.0.1 , directory >= 1.0.0.0@@ -33,7 +31,6 @@ , MissingH >= 1.0.1 , mtl >= 2.1 , network >= 2.4.1 && < 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@@ -42,10 +39,9 @@ , unix >= 2.5.0.0 , unordered-containers >= 0.2 && < 0.3 , case-insensitive >= 1.2- , wai >= 2.0 && < 3- , warp >= 2.0 && < 3+ , wai >= 3.0.0.2 && < 4+ , warp >= 3.0 && < 4 Default-Extensions: Arrows- GeneralizedNewtypeDeriving OverloadedStrings ScopedTypeVariables Ghc-Options: -Wall -fno-warn-unused-matches -threaded
src/DirectoryUtils.hs view
@@ -19,7 +19,7 @@ module DirectoryUtils ( walkTree ) where -import Control.Exception (catch, SomeException)+import Control.Exception (catch) import Control.Monad import Data.List import qualified Data.Text as T@@ -43,12 +43,11 @@ -- file name of the file/directory being visited. 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 (listDirectory d)- (\(e :: SomeException) -> do+ (\(e :: IOError) -> do putStrLn $ "Error retrieving directory contents: " ++ show e -- Log errors return []) -- Sort
src/Handlers.hs view
@@ -25,22 +25,20 @@ ) where import Blaze.ByteString.Builder (fromByteString)+import Control.Exception (bracket) import Data.ByteString (ByteString)-import qualified Data.ByteString as S+import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as L-import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI-import Data.Conduit (Flush(..), ($$), mapOutput)-import qualified Data.Conduit.List as CL-import Data.Conduit.Binary (sourceHandleRange) import Data.IORef (IORef, readIORef)+import Data.List (foldl') import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8)-import Network.HTTP.Types (Status, Header, partialContent206, forbidden403, notImplemented501, ok200, notFound404)+import Network.HTTP.Types (Status, Header, partialContent206, forbidden403, badRequest400, ok200, notFound404) import Network.HTTP.Types.Header (hConnection, hContentLength, hContentType)-import Network.Wai (Application, Request, Response, responseSourceBracket, requestBody, requestHeaders, responseLBS)+import Network.Wai (Application, Request, Response, responseStream, requestBody, requestHeaderRange, responseLBS) import Filesystem.Path (FilePath, (</>)) import Filesystem.Path.CurrentOS (encodeString, fromText) import qualified Filesystem as FS@@ -75,18 +73,21 @@ serveStaticFile req mimeType fp = do 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 <- FS.getSize fp- response <- serveFile fsz ranges- return $ response+ case requestHeaderRange req of+ Just value ->+ case parseRangeHeader value of+ Just (l, h) -> serve (Just l, h)+ Nothing -> sendError badRequest400+ Nothing ->+ serve (Nothing, Nothing) where- sfp :: String+ serve range = do+ fsz <- FS.getSize fp+ return $ serveFile fsz range+ sfp = encodeString fp - serveFile fsz [(l,h)] = do+ serveFile fsz (l,h) = do let l' = maybe 0 id l let h' = maybe (fsz-1) id h let n = (h' - l' + 1)@@ -95,19 +96,27 @@ , hdrContentRange l' h' fsz , hdrAcceptRangesBytes , hdrConnectionClose ]- let src hnd = mapOutput (Chunk . fromByteString) $ sourceHandleRange hnd (Just l') (Just n)- responseSourceBracket- (IO.openFile sfp IO.ReadMode)- (IO.hClose)- (\hnd -> return (partialContent206, hdrs, src hnd))+ responseStream partialContent206 hdrs $ \write _ ->+ bracket+ (IO.openFile sfp IO.ReadMode)+ IO.hClose+ (\hnd -> do+ IO.hSeek hnd IO.AbsoluteSeek l'+ streamBody hnd write $ fromIntegral n) - serveFile _ _ = do- -- This requires multipart/byteranges, but we don't support that as of yet.- sendError notImplemented501+ bufSize = 32768 + streamBody hnd write = go+ where+ go 0 = return ()+ go n = B.hGet hnd (min bufSize n) >>= \s ->+ case B.length s of+ 0 -> return ()+ n' -> write (fromByteString s) >> go (n - n')+ -- Handler for the root description. rootDescriptionHandler :: State -> IO Response-rootDescriptionHandler (c,mc,ai,s,_) = do+rootDescriptionHandler (c,mc,_,s,_) = do logMessage "Got request for root description." let xml = generateDescriptionXml c mc s return $ responseLBS ok200 [ hdrConnectionClose@@ -124,13 +133,13 @@ else serveStaticFile req mimeType fp where- fp = foldl (</>) root (map fromText path)+ fp = foldl' (</>) root (map fromText path) mimeType = guessMimeType fp dotDot = ".." -- Handle requests for content. contentHandler :: Request -> State -> Text -> IO Response-contentHandler req (c,mc,ai,s,objects_) oid = do+contentHandler req (_,_,_,_,objects_) oid = do objects <- readIORef objects_ -- Current snapshot of object tree. logMessage $ printf "Got request for CONTENT for objectId=%s" (T.unpack oid) -- Serve the file which the object maps to.@@ -146,32 +155,25 @@ -- Handle requests for device CONTROL urls. serviceControlHandler :: State -> DeviceType -> Application-serviceControlHandler (c,mc,ai,s,objects_) deviceType req = do+serviceControlHandler (c,_,_,_,objects_) deviceType req respond = do objects <- readIORef objects_ -- Current snapshot of object tree. logMessage $ printf "Got request for CONTROL for service '%s'" $ deviceTypeToString deviceType -- Parse the SOAP request- requestXml <- fmap S.concat $ requestBody req $$ CL.consume+ requestXml <- requestBody req logMessage $ "Request: " ++ (show requestXml) action <- 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 xml_- Nothing ->- sendError notFound404- where- handleCDA st a objects = do- sendXml $ generateActionResponseXml c st objects a- handleCMA _ =+ Just (ContentDirectoryAction_ cda) ->+ sendXml (generateActionResponseXml c deviceType objects cda) >>= respond+ Just (ConnectionManagerAction_ _) -> -- 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 notFound404-+ sendError notFound404 >>= respond+ Nothing ->+ sendError notFound404 >>= respond -- Last resort handler. fallbackHandler :: IO Response@@ -205,10 +207,6 @@ hdrContentLength :: (Show a, Integral a) => a -> Header hdrContentLength l = (hContentLength, encodeUtf8 $ T.pack $ show l)---- Name of the range header.-rangeHeader :: CI ByteString-rangeHeader = CI.mk "range" -- XML content type xmlContentType :: Header
src/HttpExtra.hs view
@@ -19,45 +19,29 @@ module HttpExtra ( parseRangeHeader ) where -import Text.ParserCombinators.Parsec--parseRange :: GenParser Char a (Maybe Integer, Maybe Integer)-parseRange =- choice [parseFullRange,- 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 '-'- i1 <- parseInteger- return (Just $ -i1, Nothing)--parseSingleByteRange :: GenParser Char a (Maybe Integer, Maybe Integer)-parseSingleByteRange = do- i1 <- parseInteger- _ <- char '-'- return (Just i1, Just i1)--parseInteger :: GenParser Char a Integer-parseInteger = do- ds <- many1 digit- return (read ds :: Integer)+import Data.ByteString.Char8 (isPrefixOf, ByteString)+import qualified Data.ByteString.Char8 as B8 -parseRanges :: GenParser Char a [(Maybe Integer, Maybe Integer)]-parseRanges = do- _ <- string "bytes="- parseRange `sepBy` char ','+-- Strip a prefix of a byte string and return the suffix (if the+-- prefix was actually a prefix).+parseLiteral :: ByteString -> ByteString -> Maybe ByteString+parseLiteral p s =+ case p `isPrefixOf` s of+ False -> Nothing+ True -> Just $ B8.drop (B8.length p) s -parseRangeHeader :: String -> [(Maybe Integer, Maybe Integer)]-parseRangeHeader s =- case parse parseRanges "-" s of- Left err -> [] -- Ignore if we can't parse- Right rs -> rs+-- Parse the Range header sent by the PS/3. The Range header that the+-- PS/3 send is always in a very simple format, so we shortcut this to+-- avoid the complexity of full HTTP/1.1 range headers.+parseRangeHeader :: ByteString -> Maybe (Integer, Maybe Integer)+parseRangeHeader s = do+ -- Extract the first part of the range+ s' <- parseLiteral "bytes=" s+ (startI, s'') <- B8.readInteger s'+ s''' <- parseLiteral "-" s''+ -- The second part of the range is optional.+ if B8.length s''' == 0 then+ return $ (startI, Nothing)+ else do+ (endI, _) <- B8.readInteger s'''+ return (startI, Just endI)
src/Main.hs view
@@ -16,6 +16,8 @@ along with this program. If not, see <http://www.gnu.org/licenses/>. -} +module Main (main) where+ import Control.Concurrent import Control.Monad.Error import Data.ConfigFile@@ -68,20 +70,20 @@ return objects application :: State -> FilePath -> Application-application state dataDirectory request = do+application state dataDirectory request respond = do case pathInfo request of ["description.xml"] ->- rootDescriptionHandler state+ rootDescriptionHandler state >>= respond ("static" : path) ->- staticHandler request (dataDirectory </> staticDir) path+ staticHandler request (dataDirectory </> staticDir) path >>= respond ("dynamic" : "services" : "ContentDirectory" : "control" : _) ->- serviceControlHandler state ContentDirectoryDevice request+ serviceControlHandler state ContentDirectoryDevice request respond ("dynamic" : "services" : "ConnectionManager" : "control" : _) ->- serviceControlHandler state ConnectionManagerDevice request+ serviceControlHandler state ConnectionManagerDevice request respond ["content" , objectId ] ->- contentHandler request state objectId+ contentHandler request state objectId >>= respond _ ->- fallbackHandler+ fallbackHandler >>= respond where staticDir = decodeString "www"
src/Object.hs view
@@ -36,6 +36,7 @@ import qualified Data.ByteString.Char8 as B8 import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as H+import Data.List (foldl') import qualified Data.Text as T import Data.Int import Data.Word (Word8)@@ -144,8 +145,6 @@ [] -> rootObjectId ((oid,_):_) -> oid -- Compute object id for the directory entry.- -- FIXME: Should handle 'file gone missing' -- simply don't prepend an- -- object in that case. deviceId <- toHexString $ P.deviceID st fileId <- toHexString $ P.fileID st let oid = T.pack $ printf "%s,%s" deviceId fileId@@ -183,7 +182,7 @@ -- Construct the objects map. return Objects { mapIdToObject = H.fromList o'- , mapParentToChildren = foldl p2c H.empty o'+ , mapParentToChildren = foldl' p2c H.empty o' , systemUpdateId = maximum $ map (objectLastModified . getObjectData . snd) o' } where
src/URIExtra.hs view
@@ -21,7 +21,7 @@ ) where import Network.URI (URI, relativeTo, parseRelativeReference, escapeURIString, isUnescapedInURI)-import Data.List+import Data.List (foldl', isSuffixOf) -- Create an URI reference (absolute or relative URI with optional fragment identifier) -- from an arbitrary string. The string is URI-encoded if necessary.@@ -52,4 +52,4 @@ mkURI' :: URI -> [URI] -> URI mkURI' =- foldl (\a r -> r `relativeTo` a)+ foldl' (\a r -> r `relativeTo` a)