hums 0.3.3 → 0.4.0
raw patch · 7 files changed
+150/−161 lines, 7 filesdep +conduitdep −enumeratordep ~blaze-builderdep ~hxtdep ~parsec
Dependencies added: conduit
Dependencies removed: enumerator
Dependency ranges changed: blaze-builder, hxt, parsec, wai, warp
Files
- hums.cabal +19/−19
- src/Action.hs +2/−2
- src/Handlers.hs +60/−70
- src/Main.hs +31/−36
- src/Object.hs +12/−11
- src/Service.hs +22/−20
- src/Soap.hs +4/−3
hums.cabal view
@@ -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
src/Action.hs view
@@ -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
src/Handlers.hs view
@@ -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
src/Main.hs view
@@ -16,27 +16,25 @@ along with this program. If not, see <http://www.gnu.org/licenses/>. -} -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.
src/Object.hs view
@@ -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.
src/Service.hs view
@@ -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
src/Soap.hs view
@@ -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