diff --git a/hums.cabal b/hums.cabal --- a/hums.cabal +++ b/hums.cabal @@ -1,5 +1,5 @@ Name: hums -Version: 0.5.0 +Version: 0.6.0 Synopsis: Haskell UPnP Media Server Description: A simple UPnP Media Server. . @@ -7,12 +7,12 @@ License: GPL License-file: COPYING.txt Category: Network -Cabal-version: >=1.6.0.1 +Cabal-version: >=1.18 Build-type: Simple Author: Bardur Arantsson Maintainer: Bardur Arantsson -data-dir: data -data-files: hums.cfg +Data-Dir: data +Data-Files: hums.cfg www/images/hums.jpg www/services/ConnectionManager/description.xml www/services/ContentDirectory/description.xml @@ -21,36 +21,38 @@ Build-Depends: base == 4.* , blaze-builder >= 0.3 && <0.4 , bytestring >= 0.9.0.1 - , conduit >= 0.5 && <0.6 + , conduit >= 1.1 && <2 + , conduit-extra >= 1.1 && <2 , ConfigFile >= 1.0.5 , containers >= 0.1.0.1 , directory >= 1.0.0.0 , filepath >= 1.1.0.0 , HaXml >= 1.22 && <1.23 - , http-types >= 0.7 && <0.8 + , http-types >= 0.8.3 && <0.9 , hxt >= 9.1 && < 9.4 , MissingH >= 1.0.1 , mtl >= 2.1 - , network >= 2.3 && < 2.5 + , 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 - , text >= 0.11 && < 0.12 + , text >= 0.11 && < 2 , transformers >= 0.3 , unix >= 2.5.0.0 , unordered-containers >= 0.2 && < 0.3 - , case-insensitive >= 0.4 && < 0.5 - , wai >= 1.3 && < 1.4 - , warp >= 1.3 && < 1.4 - Extensions: Arrows + , case-insensitive >= 1.2 + , wai >= 2.0 && < 3 + , warp >= 2.0 && < 3 + Default-Extensions: Arrows GeneralizedNewtypeDeriving OverloadedStrings ScopedTypeVariables - ghc-options: -Wall -fno-warn-unused-matches -threaded - hs-source-dirs: src - Main-is: Main.hs - Other-modules: Action + Ghc-Options: -Wall -fno-warn-unused-matches -threaded + Hs-Source-Dirs: src + Main-Is: Main.hs + Default-Language: Haskell2010 + Other-Modules: Action Configuration DirectoryUtils Handlers diff --git a/src/Handlers.hs b/src/Handlers.hs --- a/src/Handlers.hs +++ b/src/Handlers.hs @@ -25,28 +25,27 @@ ) where 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.Char8 as B8 import qualified Data.ByteString.Lazy as L import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI -import Data.Conduit (ResourceT, Flush(..), ($$), ($=)) +import Data.Conduit (Flush(..), ($$), mapOutput) import qualified Data.Conduit.List as CL -import Data.Conduit.Binary (sourceFileRange) +import Data.Conduit.Binary (sourceHandleRange) 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, partialContent206, forbidden403, notImplemented501, ok200, notFound404) import Network.HTTP.Types.Header (hConnection, hContentLength, hContentType) -import Network.Wai (Application, Request, Response(..), requestBody, requestHeaders, responseLBS) +import Network.Wai (Application, Request, Response, responseSourceBracket, requestBody, requestHeaders, responseLBS) import Filesystem.Path (FilePath, ()) import Filesystem.Path.CurrentOS (encodeString, fromText) import qualified Filesystem as FS import Prelude hiding (FilePath) +import qualified System.IO as IO import Text.Printf (printf) import Soap @@ -72,7 +71,7 @@ -} -serveStaticFile :: Request -> ByteString -> FilePath -> ResourceT IO Response +serveStaticFile :: Request -> ByteString -> FilePath -> IO Response serveStaticFile req mimeType fp = do logMessage $ printf "Serving file '%s'..." $ sfp -- Do we have a range header? @@ -80,31 +79,34 @@ Just value -> parseRangeHeader $ B8.unpack value Nothing -> [(Nothing, Nothing)] -- whole file -- Serve the ranges. - fsz <- lift $ FS.getSize fp - serveFile fsz ranges + fsz <- FS.getSize fp + response <- serveFile fsz ranges + return $ response where + sfp :: String sfp = encodeString fp serveFile fsz [(l,h)] = do let l' = maybe 0 id l let h' = maybe (fsz-1) id h let n = (h' - l' + 1) - let src = (sourceFileRange sfp (Just l') (Just n)) $= - (CL.map $ Chunk . fromByteString) - return $ ResponseSource partialContent206 - [ hdrContentLength n + let hdrs = [ hdrContentLength n , (hContentType, mimeType) , hdrContentRange l' h' fsz , hdrAcceptRangesBytes - , hdrConnectionClose - ] src + , 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)) serveFile _ _ = do -- This requires multipart/byteranges, but we don't support that as of yet. sendError notImplemented501 -- Handler for the root description. -rootDescriptionHandler :: State -> ResourceT IO Response +rootDescriptionHandler :: State -> IO Response rootDescriptionHandler (c,mc,ai,s,_) = do logMessage "Got request for root description." let xml = generateDescriptionXml c mc s @@ -114,7 +116,7 @@ ] xml -- Handle static files. -staticHandler :: Request -> FilePath -> [Text] -> ResourceT IO Response +staticHandler :: Request -> FilePath -> [Text] -> IO Response staticHandler req root path = do logMessage $ "Got request for static content: " ++ (show path) if dotDot `elem` path then -- Reject relative URLs. @@ -127,9 +129,9 @@ dotDot = ".." -- Handle requests for content. -contentHandler :: Request -> State -> Text -> ResourceT IO Response +contentHandler :: Request -> State -> Text -> IO Response contentHandler req (c,mc,ai,s,objects_) oid = do - objects <- lift $ readIORef objects_ -- Current snapshot of object tree. + 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. case findByObjectId oid objects of @@ -145,12 +147,12 @@ -- Handle requests for device CONTROL urls. serviceControlHandler :: State -> DeviceType -> Application serviceControlHandler (c,mc,ai,s,objects_) deviceType req = do - objects <- lift $ readIORef objects_ -- Current snapshot of object tree. + 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 logMessage $ "Request: " ++ (show requestXml) - action <- lift $ parseControlSoapXml $ T.unpack $ decodeUtf8 requestXml + action <- parseControlSoapXml $ T.unpack $ decodeUtf8 requestXml logMessage $ "Action: " ++ (show action) -- Deal with the action case action of @@ -172,24 +174,24 @@ -- Last resort handler. -fallbackHandler :: ResourceT IO Response +fallbackHandler :: IO Response fallbackHandler = return $ responseLBS notFound404 [] "" -- Send an empty error response. -sendError :: Status -> ResourceT IO Response +sendError :: Status -> IO Response sendError s = return $ responseLBS s [ hdrConnectionClose , hdrContentLength (0 :: Integer) ] "" -- Send generated XML. -sendXml :: L.ByteString -> ResourceT IO Response +sendXml :: L.ByteString -> IO Response sendXml xml = return $ responseLBS ok200 [ hdrConnectionClose , hdrContentLength (L.length xml) , xmlContentType ] xml -logMessage :: String -> ResourceT IO () -logMessage m = liftIO $ putStrLn m +logMessage :: String -> IO () +logMessage m = 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 @@ -25,8 +25,8 @@ import Network.Wai (Application, Request(..)) import Network.Wai.Handler.Warp (runSettings, defaultSettings, - settingsTimeout, - settingsPort) + setTimeout, + setPort) import Filesystem.Path (FilePath, ()) import Filesystem.Path.CurrentOS (decodeString, encodeString) import Prelude hiding (FilePath) @@ -113,9 +113,9 @@ -- Start serving. putStrLn "Establishing HTTP server..." _ <- forkIO $ do - let settings = defaultSettings { settingsPort = (httpServerPort c) - , settingsTimeout = 86400 - } + let settings = setPort (httpServerPort c) $ + setTimeout 86400 $ + defaultSettings runSettings settings (application st dataDirectory) _ <- putStrLn "Done." diff --git a/src/URIExtra.hs b/src/URIExtra.hs --- a/src/URIExtra.hs +++ b/src/URIExtra.hs @@ -20,8 +20,7 @@ , mkURI ) where -import Network.URI -import Data.Maybe +import Network.URI (URI, relativeTo, parseRelativeReference, escapeURIString, isUnescapedInURI) import Data.List -- Create an URI reference (absolute or relative URI with optional fragment identifier) @@ -53,4 +52,4 @@ mkURI' :: URI -> [URI] -> URI mkURI' = - foldl (\a r -> fromJust $ r `relativeTo` a) + foldl (\a r -> r `relativeTo` a)