diff --git a/hums.cabal b/hums.cabal --- a/hums.cabal +++ b/hums.cabal @@ -1,5 +1,5 @@ Name: hums -Version: 0.4.1 +Version: 0.4.2 Synopsis: Haskell UPnP Media Server Description: A simple UPnP Media Server. . @@ -21,30 +21,30 @@ Build-Depends: base == 4.* , blaze-builder >= 0.3 && <0.4 , bytestring >= 0.9.0.1 - , conduit >= 0.2 && <0.3 + , conduit >= 0.4 && <0.5 , ConfigFile >= 1.0.5 , containers >= 0.1.0.1 , directory >= 1.0.0.0 , filepath >= 1.1.0.0 - , HaXml == 1.20.* - , haskell98 - , http-types >= 0.6 && <0.7 + , HaXml >= 1.22 && <1.23 + , http-types >= 0.6.9 && <0.7 , hxt >= 9.1 && < 9.2 , MissingH >= 1.0.1 , mtl == 2.0.* , network >= 2.3 && < 2.4 , parsec >= 3.0 && < 3.2 + , system-uuid >= 2.1 && < 2.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 >= 1.1 && < 1.2 - , warp >= 1.1 && < 1.2 + , case-insensitive >= 0.4 && < 0.5 + , wai >= 1.2 && < 1.3 + , warp >= 1.2 && < 1.3 Extensions: Arrows GeneralizedNewtypeDeriving OverloadedStrings + ScopedTypeVariables ghc-options: -Wall -fno-warn-unused-matches -threaded hs-source-dirs: src Main-is: Main.hs diff --git a/src/DirectoryUtils.hs b/src/DirectoryUtils.hs --- a/src/DirectoryUtils.hs +++ b/src/DirectoryUtils.hs @@ -19,10 +19,12 @@ module DirectoryUtils ( walkTree ) where -import System.Directory +import Control.Exception (catch, SomeException) import Control.Monad -import System.FilePath import Data.List +import Prelude hiding (catch) +import System.Directory +import System.FilePath -- Performs a pre-order traversal of a directory. -- It calls f a0 a fp for each file/directory, where @@ -37,7 +39,7 @@ -- we just pretend there are none. allNames <- catch (getDirectoryContents d) - (\e -> do + (\(e :: SomeException) -> do putStrLn $ "Error retrieving directory contents: " ++ show e -- Log errors return []) -- Filter out the special directories. diff --git a/src/Handlers.hs b/src/Handlers.hs --- a/src/Handlers.hs +++ b/src/Handlers.hs @@ -33,14 +33,14 @@ 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 (ResourceT, Flush(..), ($$), ($=)) 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.HTTP.Types (Status, Header, partialContent206, forbidden403, notImplemented501, ok200, notFound404, headerContentType, headerContentLength, headerConnection) import Network.Wai (Application, Request, Response(..), requestBody, requestHeaders, responseLBS) import System.FilePath import System.IO (withFile, hFileSize, IOMode(..)) @@ -88,34 +88,36 @@ let l' = maybe 0 id l let h' = maybe (fsz-1) id h let n = (h' - l' + 1) - let src = fmap (Chunk . fromByteString) $ sourceFileRange fp (Just l') (Just n) - return $ ResponseSource status206 [ hdrContentLength n - , headerContentType mimeType - , hdrContentRange l' h' fsz - , hdrAcceptRangesBytes - , hdrConnectionClose - ] src + let src = (sourceFileRange fp (Just l') (Just n)) $= + (CL.map $ Chunk . fromByteString) + return $ ResponseSource partialContent206 + [ 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 + sendError notImplemented501 -- Handler for the root description. rootDescriptionHandler :: State -> ResourceT IO Response rootDescriptionHandler (c,mc,ai,s,_) = do logMessage "Got request for root description." let xml = generateDescriptionXml c mc s - return $ responseLBS statusOK [ hdrConnectionClose - , hdrContentLength (L.length xml) - , headerContentType "text/xml" - ] xml + return $ responseLBS ok200 [ hdrConnectionClose + , hdrContentLength (L.length xml) + , headerContentType "text/xml" + ] xml -- Handle static files. 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 + sendError forbidden403 else serveStaticFile req mimeType fp where @@ -137,7 +139,7 @@ fp = objectFileName od mt = objectMimeType od Nothing -> - sendError statusNotFound + sendError notFound404 -- Handle requests for device CONTROL urls. serviceControlHandler :: State -> DeviceType -> Application @@ -157,7 +159,7 @@ ConnectionManagerAction_ cma -> handleCMA cma return xml_ Nothing -> - sendError statusNotFound + sendError notFound404 where handleCDA st a objects = do sendXml $ generateActionResponseXml c st objects a @@ -165,12 +167,12 @@ -- 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 statusNotFound + sendError notFound404 -- Last resort handler. fallbackHandler :: ResourceT IO Response -fallbackHandler = return $ responseLBS statusNotFound [] "" +fallbackHandler = return $ responseLBS notFound404 [] "" -- Send an empty error response. sendError :: Status -> ResourceT IO Response @@ -180,10 +182,10 @@ -- Send generated XML. sendXml :: L.ByteString -> ResourceT IO Response -sendXml xml = return $ responseLBS statusOK [ hdrConnectionClose - , hdrContentLength (L.length xml) - , headerContentType "text/xml" - ] xml +sendXml xml = return $ responseLBS ok200 [ hdrConnectionClose + , hdrContentLength (L.length xml) + , headerContentType "text/xml" + ] xml logMessage :: String -> ResourceT IO () logMessage m = liftIO $ putStrLn m @@ -198,7 +200,7 @@ hdrContentRange :: Integer -> Integer -> Integer -> Header hdrContentRange l h s = (CI.mk "content-range", B8.pack $ printf "%d-%d/%d" l h s) -hdrContentLength :: Integral a => a -> Header +hdrContentLength :: (Show a, Integral a) => a -> Header hdrContentLength l = headerContentLength $ encodeUtf8 $ T.pack $ show l -- Name of the range header. diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -20,13 +20,12 @@ 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 Data.UUID () import Network.Utils import Network.Wai (Application, Request(..)) import Network.Wai.Handler.Warp (run) import System.FilePath +import qualified System.UUID.V4 as U import Text.Printf import Configuration @@ -98,7 +97,7 @@ appInfo <- getApplicationInformation -- Build configurations, etc. - u <- fmap (U.toString . fromJust) U1.nextUUID + u <- fmap show U.uuid putStrLn $ "My UUID is: " ++ u let mc = defaultMediaServerConfiguration u let services = [ ContentDirectoryDevice, ConnectionManagerDevice ] diff --git a/src/Service.hs b/src/Service.hs --- a/src/Service.hs +++ b/src/Service.hs @@ -64,24 +64,24 @@ comment :: String -> Content () comment c = CMisc (Comment c) () -simpleElement :: Name -> [Content ()] -> Content () -simpleElement n c = CElem (Elem n [] c) () +simpleElement :: String -> [Content ()] -> Content () +simpleElement n c = CElem (Elem (N n) [] c) () -textElement :: Name -> String -> Content () +textElement :: String -> String -> Content () textElement n t = optTextElement n $ Just t emptyElement :: Name -> Content () -emptyElement n = elementToContent $ Elem n [] [] +emptyElement n = elementToContent $ Elem (N n) [] [] text :: String -> Content () text t = CString False t () -optTextElement :: String -> Maybe String -> Content () +optTextElement :: Name -> Maybe String -> Content () optTextElement n Nothing = comment $ printf " %s omitted" n -optTextElement n (Just t) = elementToContent $ Elem n [] [text t] +optTextElement n (Just t) = elementToContent $ Elem (N n) [] [text t] -attribute :: Name -> String -> Attribute -attribute n v = (n, AttValue [Left v]) +attribute :: String -> String -> Attribute +attribute n v = (N n, AttValue [Left v]) mkDocument :: Element () -> Document () mkDocument rootElement = @@ -146,7 +146,7 @@ generateDescription :: Configuration -> MediaServerConfiguration -> [DeviceType] -> Document () generateDescription c mc services = (mkDocument - (Elem "root" [attribute "xmlns" "urn:schemas-upnp-org:device-1-0"] + (Elem (N "root") [attribute "xmlns" "urn:schemas-upnp-org:device-1-0"] [ simpleElement "specVersion" [ textElement "major" "1" , textElement "minor" "0" @@ -174,9 +174,9 @@ deviceType = deviceTypeToString MediaServer -- dlna = if useDlna mc then (Just "DMS-1.00") else Nothing -mkBrowseResponse :: Integral a => Configuration -> DeviceType -> Objects -> a -> a -> Element () -> Element () +mkBrowseResponse :: (Show a, Integral a) => Configuration -> DeviceType -> Objects -> a -> a -> Element () -> Element () mkBrowseResponse cfg st os numberReturned totalMatches didl = - ( Elem "u:BrowseResponse" [ serviceNs "u" st ] + ( Elem (N "u:BrowseResponse") [ serviceNs "u" st ] [ textElement "Result" didlXml , textElement "NumberReturned" $ show numberReturned -- CD/§2.7.4.2 , textElement "TotalMatches" $ show totalMatches -- CD/§2.7.4.2 @@ -222,7 +222,7 @@ generateActionResponseXml _ st os ContentDirectoryGetSystemUpdateId = generateResponseXml body where - body = ( Elem "u:GetSystemUpdateIDResponse" [ serviceNs "u" st ] + body = ( Elem (N "u:GetSystemUpdateIDResponse") [ serviceNs "u" st ] [ textElement "Id" $ show $ systemUpdateId os ] ) generateActionResponseXml cfg st os (ContentDirectoryBrowse ba) = @@ -231,21 +231,21 @@ generateActionResponseXml _ st _ ContentDirectoryGetSearchCapabilities = generateResponseXml body where - body = ( Elem "u:GetSearchCapabilitiesResponse" [ serviceNs "u" st ] + body = ( Elem (N "u:GetSearchCapabilitiesResponse") [ serviceNs "u" st ] [ emptyElement "SearchCaps" ] -- No search capabilities (CD/§2.5.18) ) generateActionResponseXml _ st _ ContentDirectoryGetSortCapabilities = generateResponseXml body where - body = ( Elem "u:GetSortCapabilitiesResponse" [ serviceNs "u" st ] + body = ( Elem (N "u:GetSortCapabilitiesResponse") [ serviceNs "u" st ] [ emptyElement "SortCaps" ] -- No sorting capabilities (CD/§2.5.19) ) generateSoapEnvelope :: Element () -> Document () generateSoapEnvelope bodyE = ( mkDocument - ( Elem "s:Envelope" [ soapNs, soapEncodingStyle ] + ( Elem (N "s:Envelope") [ soapNs, soapEncodingStyle ] [ simpleElement "s:Body" [elementToContent bodyE] ] ) ) @@ -265,7 +265,7 @@ ) where od = getObjectData o - en = getObjectElementName o + en = N $ getObjectElementName o ee = generateExtraElements cfg (oid,o) as = [ attribute "id" $ T.unpack oid , attribute "parentID" $ T.unpack $ objectParentId od @@ -292,7 +292,7 @@ generateExtraElementsForFile :: Configuration -> ObjectId -> ObjectData -> [Element ()] generateExtraElementsForFile cfg oid d = - [ Elem "res" + [ Elem (N "res") [ attribute "protocolInfo" protocolInfo , attribute "size" $ printf "%d" $ objectFileSize d ] -- TODO: should be disabled by Transcoding flag! [ contentUrl ] @@ -364,7 +364,7 @@ -- Create the DIDL result object. mkDidl :: [Element ()] -> Element () mkDidl es = - ( Elem "DIDL-Lite" + ( Elem (N "DIDL-Lite") [ attribute "xmlns:dc" "http://purl.org/dc/elements/1.1/" , attribute "xmlns:upnp" "urn:schemas-upnp-org:metadata-1-0/upnp/" , attribute "xmlns" "urn:schemas-upnp-org:metadata-1-0/DIDL-Lite/" ] diff --git a/src/StorableExtra.hs b/src/StorableExtra.hs --- a/src/StorableExtra.hs +++ b/src/StorableExtra.hs @@ -18,9 +18,9 @@ module StorableExtra ( toHexString ) where -import Storable import Data.Word import Foreign.Marshal.Utils (with) +import Foreign.Storable import Text.Printf -- Convert a storable to an [Word8].