Server.hs

{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
module Hoovie.Server (
        HoovieService(..),
        HoovieServerHandle,
        startHoovieServer,
        stopHoovieServer
    ) where

import Control.Concurrent   (forkIO, ThreadId, killThread)
import Data.List            (intersperse)
import Debug.Trace          (trace)
import Network.Info         (NetworkInterface, ipv4)
import Control.Applicative  ((<|>))
import Data.FileEmbed       (embedFile)

import qualified Data.ByteString.Char8 as BC

import Snap.Core
import Snap.Http.Server

import Hoovie.SSDP
import Hoovie.SOAP
import Hoovie.Stream
import Hoovie.Monitor

data HoovieService = HoovieService {
        hsInterface :: NetworkInterface,
        hsPort      :: Int,
        hsPaths     :: [FilePath],
        hsDatabase  :: FilePath
    } deriving (Show)

data HoovieServerHandle = HoovieServerHandle ThreadId SSDPHandle MonitorHandle

snapConfig :: MonadSnap m => String -> Int -> Config m a
snapConfig ip port = ( setLocale "en_US"
                     . setPort   port
                     . setBind   (BC.pack ip)
                     ) emptyConfig

startHoovieServer :: HoovieService -> IO HoovieServerHandle
startHoovieServer (HoovieService interface port paths db) = do
    mon  <- startMonitor paths db
    ssdp <- startSsdpServer $ SSDPService interface port ('/':hoovieXmlUri) "Hoovie" "0.1" [SSDPMediaServer, SSDPContentDirectory, SSDPConnectionManager]
    http <- forkIO          $ httpServe (snapConfig (show $ ipv4 interface) port) (site (getURL ssdp) (getUUID ssdp) db)
    return $ HoovieServerHandle http ssdp mon

stopHoovieServer :: HoovieServerHandle -> IO ()
stopHoovieServer (HoovieServerHandle http ssdp mon) = do
    stopSsdpServer ssdp
    stopMonitor mon
    killThread http

site :: String -> String -> FilePath -> Snap ()
site url uuid db =
    logRequest                <|>
    soapHandler url uuid db   <|>
    route [("stream/:id", streamHandler db),
           ("folder/:id", iconHandler),
           ("icon/:id",   iconHandler)]

iconHandler :: Snap ()
iconHandler = do
    -- rid <- getParam "id"
    staticSendFile "image/jpg" $(embedFile "static/hoovie.jpg")

logRequest :: Snap a
logRequest = do
    request <- getRequest
    trace (show (rqMethod request) ++ " " ++ show (rqURI request) ++ "\n" ++
           concat (intersperse "\n" (["   " ++ show k ++ ": " ++ show v | (k, v) <- listHeaders $ headers request]))) pass