diff --git a/hums.cabal b/hums.cabal --- a/hums.cabal +++ b/hums.cabal @@ -1,5 +1,5 @@ Name: hums -Version: 0.3.3 +Version: 0.4.0 Synopsis: Haskell UPnP Media Server Description: A simple UPnP Media Server. . @@ -19,29 +19,29 @@ Executable hums Build-Depends: base == 4.* - , haskell98 - , network == 2.3.* - , filepath >= 1.1.0.0 - , parsec >= 2.1.0.0 && < 3.0 - , unix >= 2.3.0.0 - , directory >= 1.0.0.0 - , containers >= 0.1.0.1 - , uuid >= 1.2.1 && < 1.3 + , blaze-builder >= 0.3 && <0.4 , bytestring >= 0.9.0.1 - , blaze-builder == 0.2.* - , MissingH >= 1.0.1 - , hxt >= 9.0.1 + , conduit >= 0.1 && <0.2 , ConfigFile >= 1.0.5 - , mtl == 2.0.* - , transformers == 0.2.* - , unordered-containers == 0.1.* - , text == 0.11.* + , containers >= 0.1.0.1 + , directory >= 1.0.0.0 + , filepath >= 1.1.0.0 , HaXml == 1.20.* - , enumerator >= 0.4.9 + , haskell98 , http-types >= 0.6 && <0.7 + , hxt >= 9.1 && < 9.2 + , MissingH >= 1.0.1 + , mtl == 2.0.* + , network >= 2.3 && < 2.4 + , parsec >= 3.0 && < 3.2 + , text >= 0.11 && < 0.12 + , transformers >= 0.2 && < 0.3 + , unix >= 2.3.0.0 + , uuid >= 1.2.1 && < 1.3 + , unordered-containers >= 0.1 && < 0.2 , case-insensitive >= 0.2 && < 0.3 - , wai >= 0.4 && < 0.5 - , warp >= 0.4 && < 0.5 + , wai >= 1.0 && < 1.1 + , warp >= 1.0 && < 1.1 Extensions: Arrows GeneralizedNewtypeDeriving OverloadedStrings diff --git a/src/Action.hs b/src/Action.hs --- a/src/Action.hs +++ b/src/Action.hs @@ -24,9 +24,9 @@ , ObjectId ) where -import Data.ByteString (ByteString) +import Data.Text (Text) -type ObjectId = ByteString +type ObjectId = Text data BrowseParameters = BrowseParameters { objectId :: ObjectId diff --git a/src/Handlers.hs b/src/Handlers.hs --- a/src/Handlers.hs +++ b/src/Handlers.hs @@ -24,35 +24,36 @@ , State ) where -import Soap -import Configuration -import Service -import Text.Printf -import Action -import Blaze.ByteString.Builder (insertByteString) -import System.IO (withFile, hFileSize, IOMode(..)) -import MimeType -import Object -import HttpExtra -import System.FilePath -import Data.ByteString (ByteString, isInfixOf) +import Blaze.ByteString.Builder (fromByteString) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Class (lift) +import Data.ByteString (ByteString) import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as B8 -import Data.IORef -import Control.Monad.Trans.Class (lift) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Network.Wai -import Data.Enumerator (Iteratee, ($$), ($=)) -import Data.Enumerator.Binary (enumFileRange) -import qualified Data.Enumerator as E -import qualified Data.Enumerator.List as EL -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8, decodeUtf8) -import Network.HTTP.Types (Status, Header, status206, statusServerError, statusOK, statusNotFound, headerContentType, headerContentLength, headerConnection) -import Data.CaseInsensitive (CI) +import qualified Data.ByteString.Lazy as L +import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI +import Data.Conduit (ResourceT, ($$)) +import qualified Data.Conduit.List as CL +import Data.Conduit.Binary (sourceFileRange) +import Data.IORef (IORef, readIORef) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Network.HTTP.Types (Status, Header, status206, statusServerError, statusOK, statusNotFound, headerContentType, headerContentLength, headerConnection) +import Network.Wai (Application, Request, Response(..), requestBody, requestHeaders, responseLBS) +import System.FilePath +import System.IO (withFile, hFileSize, IOMode(..)) +import Text.Printf (printf) +import Soap +import Configuration +import Service +import Action +import MimeType +import Object +import HttpExtra + type State = (Configuration, MediaServerConfiguration, ApplicationInformation, [DeviceType], IORef Objects) {- @@ -72,7 +73,7 @@ fileSize fp = withFile fp ReadMode $ \h -> hFileSize h -serveStaticFile :: Request -> ByteString -> FilePath -> Iteratee ByteString IO Response +serveStaticFile :: Request -> ByteString -> FilePath -> ResourceT IO Response serveStaticFile req mimeType fp = do logMessage $ printf "Serving file '%s'..." fp -- Do we have a range header? @@ -87,27 +88,20 @@ let l' = maybe 0 id l let h' = maybe (fsz-1) id h let n = (h' - l' + 1) - return $ ResponseEnumerator $ \f -> - E.run_ $ (enumFileRange fp l h $= EL.map insertByteString) $$ f status206 - [ hdrContentLength n - , headerContentType mimeType - , hdrContentRange l' h' fsz - , hdrAcceptRangesBytes - , hdrConnectionClose - ] + let src = fmap fromByteString $ sourceFileRange fp (Just l') (Just n) + return $ ResponseSource status206 [ hdrContentLength n + , headerContentType mimeType + , hdrContentRange l' h' fsz + , hdrAcceptRangesBytes + , hdrConnectionClose + ] src + serveFile _ _ = do -- This requires multipart/byteranges, but we don't support that as of yet. sendError statusServerError --- Regular expressions for avoiding relative URLs. These --- are overly conservative, but what the heck... -dotDotSlash :: ByteString -dotDotSlash = "../" -slashDotDot :: ByteString -slashDotDot = "/.." - -- Handler for the root description. -rootDescriptionHandler :: State -> Iteratee ByteString IO Response +rootDescriptionHandler :: State -> ResourceT IO Response rootDescriptionHandler (c,mc,ai,s,_) = do logMessage "Got request for root description." let xml = generateDescriptionXml c mc s @@ -117,23 +111,23 @@ ] xml -- Handle static files. -staticHandler :: Request -> String -> ByteString -> Iteratee ByteString IO Response -staticHandler req root p = do - logMessage $ "Got request for static content: " ++ (show p) - if dotDotSlash `isInfixOf` p || -- Reject relative URLs. - slashDotDot `isInfixOf` p then +staticHandler :: Request -> String -> [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. sendError statusServerError else serveStaticFile req mimeType fp where - fp = root (T.unpack $ decodeUtf8 p) + fp = foldl () root (map T.unpack path) mimeType = guessMimeType fp + dotDot = ".." -- Handle requests for content. -contentHandler :: Request -> State -> ByteString -> Iteratee ByteString IO Response +contentHandler :: Request -> State -> Text -> ResourceT IO Response contentHandler req (c,mc,ai,s,objects_) oid = do objects <- lift $ readIORef objects_ -- Current snapshot of object tree. - logMessage $ printf "Got request for CONTENT for objectId=%s" (B8.unpack oid) + logMessage $ printf "Got request for CONTENT for objectId=%s" (T.unpack oid) -- Serve the file which the object maps to. case findByObjectId oid objects of Just o -> @@ -146,12 +140,12 @@ sendError statusNotFound -- Handle requests for device CONTROL urls. -serviceControlHandler :: State -> DeviceType -> ByteString -> Iteratee ByteString IO Response -serviceControlHandler (c,mc,ai,s,objects_) deviceType _ = do +serviceControlHandler :: State -> DeviceType -> Application +serviceControlHandler (c,mc,ai,s,objects_) deviceType req = do objects <- lift $ 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 EL.consume + requestXml <- fmap S.concat $ requestBody req $$ CL.consume logMessage $ "Request: " ++ (show requestXml) action <- lift $ parseControlSoapXml $ T.unpack $ decodeUtf8 requestXml logMessage $ "Action: " ++ (show action) @@ -175,28 +169,24 @@ -- Last resort handler. -fallbackHandler :: Iteratee ByteString IO Response -fallbackHandler = do - return $ responseLBS statusNotFound [] "" +fallbackHandler :: ResourceT IO Response +fallbackHandler = return $ responseLBS statusNotFound [] "" -- Send an empty error response. -sendError :: Monad m => Status -> Iteratee ByteString m Response -sendError s = return $ - responseLBS s [ hdrConnectionClose - , hdrContentLength (0 :: Integer) - ] "" +sendError :: Status -> ResourceT IO Response +sendError s = return $ responseLBS s [ hdrConnectionClose + , hdrContentLength (0 :: Integer) + ] "" -- Send generated XML. -sendXml :: (MonadIO m, Functor m) => L.ByteString -> Iteratee ByteString m Response -sendXml xml = return $ - responseLBS statusOK [ hdrConnectionClose - , hdrContentLength (L.length xml) - , headerContentType "text/xml" - ] xml +sendXml :: L.ByteString -> ResourceT IO Response +sendXml xml = return $ responseLBS statusOK [ hdrConnectionClose + , hdrContentLength (L.length xml) + , headerContentType "text/xml" + ] xml -logMessage :: (MonadIO m, Functor m) => String -> Iteratee a m () -logMessage m = do - liftIO $ putStrLn m +logMessage :: String -> ResourceT IO () +logMessage m = liftIO $ putStrLn m -- Convenience functions for DRY construction of headers. hdrConnectionClose :: Header diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -16,27 +16,25 @@ along with this program. If not, see . -} -import Network.Utils -import SimpleServiceDiscoveryProtocol -import Configuration -import Control.Concurrent -import Service -import Text.Printf +import Control.Concurrent +import Control.Monad.Error +import Data.ConfigFile +import Data.IORef +import Data.Maybe (fromJust) import qualified Data.UUID as U import qualified Data.UUID.V1 as U1 +import Network.Utils +import Network.Wai (Application, Request(..)) +import Network.Wai.Handler.Warp (run) +import System.FilePath +import Text.Printf + +import Configuration +import Handlers import Object -import Control.Monad.Error -import System.FilePath -import Data.Maybe (fromJust) -import Data.ConfigFile import Paths_hums -import Data.IORef -import Handlers -import Network.Wai (Application, Response, Request(..)) -import Network.Wai.Handler.Warp (run) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Enumerator (Iteratee) +import Service +import SimpleServiceDiscoveryProtocol defaultMediaServerConfiguration :: String -> MediaServerConfiguration defaultMediaServerConfiguration uuid_ = @@ -65,9 +63,21 @@ putStrLn $ printf "Scanning completed" return objects -handleIf :: (Maybe a) -> (a -> Iteratee ByteString IO Response) -> Iteratee ByteString IO Response -> Iteratee ByteString IO Response -handleIf Nothing _ noMatch = noMatch -handleIf (Just x) match _ = match x +application :: State -> String -> Application +application state dataDirectory request = do + case pathInfo request of + ["description.xml"] -> + rootDescriptionHandler state + ("static" : path) -> + staticHandler request (dataDirectory "www") path + ("dynamic" : "services" : "ContentDirectory" : "control" : _) -> + serviceControlHandler state ContentDirectoryDevice request + ("dynamic" : "services" : "ConnectionManager" : "control" : _) -> + serviceControlHandler state ConnectionManagerDevice request + ["content" , objectId ] -> + contentHandler request state objectId + _ -> + fallbackHandler main :: IO () main = niceSocketsDo $ do @@ -94,24 +104,9 @@ let services = [ ContentDirectoryDevice, ConnectionManagerDevice ] let st = (c,mc,appInfo,services, defaultObjects) - let myApplication :: Application - myApplication r = - ifPath "/description.xml" (\_ -> rootDescriptionHandler st) $ - ifPrefix "/static/" (staticHandler r $ dataDirectory "www") $ - ifPrefix "/dynamic/services/ContentDirectory/control" (serviceControlHandler st ContentDirectoryDevice) $ - ifPrefix "/dynamic/services/ConnectionManager/control" (serviceControlHandler st ConnectionManagerDevice) $ - ifPrefix "/content/" (contentHandler r st) $ - fallbackHandler - where - ifPath p t f = handleIf (isPath p) t f - ifPrefix p t f = handleIf (isPrefix p) t f - isPath p = if rawPathInfo r == p then Just () else Nothing - isPrefix p | B.isPrefixOf p $ rawPathInfo r = Just $ B.drop (B.length p) $ rawPathInfo r - isPrefix _ = Nothing - -- Start serving. putStrLn "Establishing HTTP server..." - _ <- forkIO $ run (httpServerPort c) myApplication + _ <- forkIO $ run (httpServerPort c) (application st dataDirectory) _ <- putStrLn "Done." -- Start broadcasting alive messages. diff --git a/src/Object.hs b/src/Object.hs --- a/src/Object.hs +++ b/src/Object.hs @@ -30,18 +30,19 @@ , findExistingByObjectId ) where -import Action -import Data.ByteString (ByteString, isPrefixOf) -import qualified Data.ByteString.Char8 as B8 -import Data.Char (isAscii) -import Data.HashMap.Strict (HashMap) +import Action +import Data.ByteString (ByteString, isPrefixOf) +import Data.Char (isAscii) +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 Text.Printf + import DirectoryUtils -import System.FilePath import MimeType -import Data.Int -import System.Posix -import Text.Printf import StorableExtra -- Root object id is defined by CD/ยง2.7.4.2. @@ -128,7 +129,7 @@ findExistingByObjectId oid os = case findByObjectId oid os of Just x -> x - Nothing -> error $ printf "Couldn't find object '%s'" $ B8.unpack oid + 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)] @@ -143,7 +144,7 @@ st <- getFileStatus fp deviceId <- toHexString $ deviceID st fileId <- toHexString $ fileID st - let oid = B8.pack $ printf "%s,%s" deviceId fileId + let oid = T.pack $ printf "%s,%s" deviceId fileId -- Compute the update ID. let lastModified = round' $ toRational $ modificationTime st -- Compute file size. diff --git a/src/Service.hs b/src/Service.hs --- a/src/Service.hs +++ b/src/Service.hs @@ -22,31 +22,33 @@ , deviceTypeToString ) where -import Text.Printf -import Text.XML.HaXml.Types -import Text.XML.HaXml.ByteStringPP +import Data.Bits +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Char8 as B8 +import Data.Int +import Data.List.Utils +import Data.Maybe (mapMaybe) +import qualified Data.Text as T +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as TL +import Data.Text.Lazy.Encoding (decodeUtf8) +import Text.Printf +import Text.XML.HaXml.Types +import Text.XML.HaXml.ByteStringPP + import Configuration import Action -import Data.Maybe (mapMaybe) import Object -import Data.List.Utils -import Data.Bits -import Data.Int import MimeType import URIExtra -import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy as T -import Data.Text.Lazy.Encoding (decodeUtf8) -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Char8 as B8 myQuote :: Text -> Text myQuote = -- TODO: There *must* be a better way to achieve our quoting needs. - T.concatMap f + TL.concatMap f where - f '<' = T.pack "<" - f '>' = T.pack ">" - f c = T.singleton c + f '<' = TL.pack "<" + f '>' = TL.pack ">" + f c = TL.singleton c sanitizeXmlChars :: String -> String sanitizeXmlChars = map f @@ -181,7 +183,7 @@ , textElement "UpdateID" $ printf "%d" $ systemUpdateId os ] ) where - didlXml = T.unpack $ myQuote $ decodeUtf8 $ element $ didl + didlXml = TL.unpack $ myQuote $ decodeUtf8 $ element $ didl generateBrowseResponse :: Configuration -> DeviceType -> Objects -> BrowseAction -> Element () generateBrowseResponse cfg st os (BrowseMetadata bps) = @@ -265,8 +267,8 @@ od = getObjectData o en = getObjectElementName o ee = generateExtraElements cfg (oid,o) - as = [ attribute "id" $ B8.unpack oid - , attribute "parentID" $ B8.unpack $ objectParentId od + as = [ attribute "id" $ T.unpack oid + , attribute "parentID" $ T.unpack $ objectParentId od ] eas = generateExtraAttributes objects (oid,o) @@ -298,7 +300,7 @@ where mimeType = B8.unpack $ objectMimeType d protocolInfo = generateProtocolInfo cfg False mimeType Nothing -- TODO: profileId - contentUrl = text $ show $ mkURI ["content", B8.unpack $ oid] $ httpServerBase cfg + contentUrl = text $ show $ mkURI ["content", T.unpack $ oid] $ httpServerBase cfg mapMaybe1 :: (a -> b) -> Maybe a -> Maybe b mapMaybe1 f Nothing = Nothing diff --git a/src/Soap.hs b/src/Soap.hs --- a/src/Soap.hs +++ b/src/Soap.hs @@ -19,8 +19,9 @@ module Soap ( parseControlSoapXml ) where -import qualified Data.ByteString.Char8 as B8 -import Text.XML.HXT.Core +import Data.Text as T +import Text.XML.HXT.Core + import Action -- Utility functions for parsing XML. @@ -63,7 +64,7 @@ si <- numberAtTag "StartingIndex" -< l rq <- numberAtTag "RequestedCount" -< l sc <- textAtTag "SortCriteria" -< l - returnA -< let bps = BrowseParameters (B8.pack oid) flt si rq sc in + returnA -< let bps = BrowseParameters (T.pack oid) flt si rq sc in ContentDirectoryBrowse $ bf bps parseCDSearchCapabilities :: ArrowXml a => a XmlTree ContentDirectoryAction