hums 0.4.1 → 0.4.2
raw patch · 6 files changed
+62/−59 lines, 6 filesdep +system-uuiddep −haskell98dep −uuiddep ~HaXmldep ~case-insensitivedep ~conduit
Dependencies added: system-uuid
Dependencies removed: haskell98, uuid
Dependency ranges changed: HaXml, case-insensitive, conduit, http-types, wai, warp
Files
- hums.cabal +9/−9
- src/DirectoryUtils.hs +5/−3
- src/Handlers.hs +26/−24
- src/Main.hs +3/−4
- src/Service.hs +18/−18
- src/StorableExtra.hs +1/−1
hums.cabal view
@@ -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
src/DirectoryUtils.hs view
@@ -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.
src/Handlers.hs view
@@ -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.
src/Main.hs view
@@ -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 ]
src/Service.hs view
@@ -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/" ]
src/StorableExtra.hs view
@@ -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].