IO.hs

module Network.Salvia.Core.IO (

    sendHeaders

  , send
  , sendStr
  , sendStrLn
  , sendBs

  , spool
  , spoolBs
  , spoolAll
  , spoolN

  , emptyQueue
  , reset

  , contents
  , contentsUtf8
  , uriEncodedPostParamsUTF8

  ) where

-- TODO: we are mixing two encoding libs. fix.

import Control.Monad.State
import Data.Encoding (decodeLazy)
import Data.Encoding.UTF8
import System.IO
import qualified Data.ByteString.Lazy as B
import qualified System.IO.UTF8 as U

import Network.Protocol.Http
import Network.Protocol.Uri (Parameters, parseQueryParams, decode)
import Network.Salvia.Core.Handler

-------------------------------------------------------------------------------

-- Send the response header to the socket.
sendHeaders :: Handler ()
sendHeaders = do
  r <- gets response
  s <- gets sock 
  lift $ hPutStr s (showMessageHeader r)

-- Queue a potential send action in the send queue.
send :: SendAction -> Handler ()
send f = modify (\m -> m { queue = (queue m) ++ [f] })

-- Queue a String for sending.
sendStr, sendStrLn :: String -> Handler ()
sendStr s   = send (flip U.hPutStr s)
sendStrLn s = send (flip U.hPutStr (s ++ "\n"))

-- Queue a ByteString for sending.
sendBs :: B.ByteString -> Handler ()
sendBs bs = send (flip B.hPutStr bs)

{-
Queue spooling the entire contents of a stream to the socket using a String
based filter.
-}
spool :: (String -> String) -> Handle -> Handler ()
spool f fd = send (\s -> U.hGetContents fd >>= \d -> U.hPutStr s (f d))

{-
Queue spooling the entire contents of a stream to the socket using a ByteString
based filter.
-}
spoolBs :: (B.ByteString -> B.ByteString) -> Handle -> Handler ()
spoolBs f fd = send (\s -> B.hGetContents fd >>= \d -> B.hPut s (f d))

{-
Spool the entire contents from one stream to another stream, after this the
handle will be closed.
-}
spoolAll :: Handle -> Handle -> Handler ()
spoolAll f t = lift $ do
  B.hGetContents f >>= B.hPut t
  hClose t

{-
Spool a fixed number of bytes from one stream to another stream, after this the
handle will be closed.
-}
spoolN :: Handle -> Handle -> Int -> Handler ()
spoolN f t n = lift $ do
  B.hGet f n >>= B.hPut t
  hClose t

-- Reset the send queue.
emptyQueue :: Handler ()
emptyQueue = putQueue []

-- Reset both the send queue and the generated response.
reset :: Handler ()
reset = do
  putResponse emptyResponse
  emptyQueue

{- |
First naive handler to retreive the request payload as a ByteString. This
probably does not handle all the quirks that the HTTP protocol specifies, but
it does the job for now. When a 'ContentLength' header field is available only
this fixed number of bytes will read from the socket. When neither the
'KeepAlive' and 'ContentLength' header fields are available the entire payload
of the request will be read from the socket. This method is probably only
useful in the case of 'PUT' request, because no decoding of 'POST' data is
handled.
-}

contents :: Handler (Maybe B.ByteString)
contents = do
  r <- gets request
  s <- gets sock
  let len = getContentLength r
      kpa = getKeepAlive     r
  lift $
    case (kpa, len) of
      (_,       Just n)  -> liftM Just (B.hGet s n)
      (Nothing, Nothing) -> liftM Just (B.hGetContents s)
      _                  -> return Nothing

{- |
Like the `contents' function but decodes the data as UTF8. Soon, time will come
that decoding will be based upon the requested encoding.
-}

contentsUtf8 :: Handler (Maybe String)
contentsUtf8 = (fmap $ decodeLazy UTF8) `liftM` contents

uriEncodedPostParamsUTF8 :: Handler (Maybe Parameters)
uriEncodedPostParamsUTF8 = liftM (>>= parseQueryParams . decode) contentsUtf8