module Network.Salvia.Impl.Handler where
import Control.Applicative
import Control.Concurrent.STM
import Control.Monad.State
import Data.ByteString.Lazy.UTF8 (fromString, toString)
import Data.Monoid
import Data.Record.Label hiding (get)
import Network.Protocol.Http hiding (hostname)
import Network.Salvia.Handler.Body
import Network.Salvia.Handler.Close
import Network.Salvia.Handler.Printer
import Network.Salvia.Impl.Context
import Network.Salvia.Interface
import Prelude hiding (mod)
import Safe
import qualified Data.ByteString.Lazy as ByteString
import qualified Data.Record.Label as L
newtype Handler p a = Handler { unHandler :: StateT (Context p) IO a }
deriving (Functor, Applicative, Monad, MonadIO, MonadState (Context p))
runHandler :: Handler p a -> Context p -> IO (a, Context p)
runHandler h = runStateT (unHandler h)
instance ForkM IO (Handler p) where
forkM a = get >>= return . fmap fst . runHandler a
instance HttpM Request (Handler p) where
http st =
do (a, s) <- runState st <$> getM cRequest
cRequest =: s >> return a
instance HttpM Response (Handler p) where
http st =
do (a, s) <- runState st <$> getM cResponse
cResponse =: s >> return a
instance RawHttpM Request (Handler p) where
rawHttp st =
do (a, s) <- runState st <$> getM cRawRequest
cRawRequest =: s >> return a
instance RawHttpM Response (Handler p) where
rawHttp st =
do (a, s) <- runState st <$> getM cRawResponse
cRawResponse =: s >> return a
instance HandleQueueM (Handler p) where
enqueueHandle f = modM cQueue (++[SendAction (f . snd)])
instance SocketQueueM (Handler p) where
enqueueSock f = modM cQueue (++[SendAction (f . fst)])
instance QueueM (Handler p) where
dequeue = headMay <$> getM cQueue <* modM cQueue (tailDef [])
instance SendM (Handler p) where
send s = enqueueHandle (\h -> ByteString.hPut h (fromString s))
sendBs bs = enqueueHandle (\h -> ByteString.hPutStr h bs)
spoolWith f fd = enqueueHandle (\h -> ByteString.hGetContents fd >>= ByteString.hPut h . fromString . f . toString)
spoolWithBs f fd = enqueueHandle (\h -> ByteString.hGetContents fd >>= ByteString.hPut h . f)
instance SocketM (Handler p) where
socket = getM cSocket
instance HandleM (Handler p) where
handle = getM cHandle
instance ClientAddressM (Handler p) where
clientAddress = getM cClientAddr
instance ServerAddressM (Handler p) where
serverAddress = getM cServerAddr
instance Monoid a => Monoid (Handler p a) where
mempty = mzero >> return mempty
mappend = mplus
instance Alternative (Handler p) where
empty = mzero
(<|>) = mplus
instance MonadPlus (Handler p) where
mzero =
do http (status =: BadRequest)
return (error "mzero/empty")
a `mplus` b =
do r <- a
s <- http (getM status)
if statusFailure s
then do response $
do status =: OK
contentLength =: (Nothing :: Maybe Integer)
emptyQueue >> mzero >> b
else return r
instance FlushM Response (Handler p) where
flushHeaders = hFlushHeaders
flushQueue _ = hFlushQueue
instance FlushM Request (Handler p) where
flushHeaders = hFlushHeaders
flushQueue _ = hFlushQueue
instance BodyM Request (Handler p) where
body = hRawBody
instance BodyM Response (Handler p) where
body = hRawBody
instance ServerM (Handler p) where
host = getM cServerHost
admin = getM cAdminMail
listen = getM cListenOn
instance Contains p (TVar q) => PayloadM p q (Handler p) where
payload st =
do pl <- getM cPayload :: Handler p p
let var = L.get select pl :: TVar q
liftIO . atomically $
do q <- readTVar var
let (s, q') = runState st q
writeTVar var q'
return s