hums 0.5.0 → 0.6.0
raw patch · 4 files changed
+52/−49 lines, 4 filesdep +conduit-extradep ~case-insensitivedep ~conduitdep ~http-types
Dependencies added: conduit-extra
Dependency ranges changed: case-insensitive, conduit, http-types, network, text, wai, warp
Files
- hums.cabal +18/−16
- src/Handlers.hs +27/−25
- src/Main.hs +5/−5
- src/URIExtra.hs +2/−3
hums.cabal view
@@ -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 <bardur@scientician.net>-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
src/Handlers.hs view
@@ -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
src/Main.hs view
@@ -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."
src/URIExtra.hs view
@@ -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)