Wai.hs

module Dingo.Internal.Server.Wai
       ( mkWaiApplication
       ) where

import           Blaze.ByteString.Builder (fromByteString, toByteString)
import           Control.DeepSeq.ByteString ()
import           Control.Monad (forM_)
import           Control.Monad.IO.Class (liftIO)
import           Data.Aeson (Value(..))
import qualified Data.Aeson.Parser as AEP
import           Data.Attoparsec (Parser)
import qualified Data.Attoparsec as AP
import           Data.ByteString (ByteString)
import           Data.Enumerator (Iteratee)
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as H
import           Data.IORef (readIORef)
import qualified Data.Label as L
import qualified Data.Map as M
import           Data.Maybe (fromMaybe, mapMaybe)
import           Data.Monoid (mempty)
import           Data.Text (Text)
import qualified Data.Text.Encoding as TE
import           Dingo.Internal.Base
import           Dingo.Internal.Html (mkHeadMerge)
import           Dingo.Internal.Server.State (ServerState, ClientSession, SessionId, ssApplicationTitle, ssBootResourceBundles, handleCallback, readCommandWithTimeout, getSession, getSessionId, cssClientSessionState)
import           Dingo.Internal.Session (lookupResource)
import           Dingo.ResourceBundle (ResourceBundle)
import           Network.HTTP.Types (statusOK, statusForbidden, headerContentType, Header, ResponseHeaders)
import           Network.Wai (Request(..), Response(..))
import qualified Network.Wai as W
import           Network.Wai.Parse (parseRequestBody, lbsSink)
import           Text.Blaze ((!), toHtml, unsafeByteStringValue)
import qualified Text.Blaze.Html4.Strict as H4
import qualified Text.Blaze.Html4.Strict.Attributes as A
import           Text.Blaze.Renderer.Utf8 (renderHtmlBuilder)
import           Web.Cookie (SetCookie(..), parseCookies, renderSetCookie)

-- Set-cookie header.
headerSetCookie :: SetCookie -> Header
headerSetCookie s = ("Set-Cookie", toByteString $ renderSetCookie s)

-- Timeout for poll requests.
longPollTimeout :: Int
longPollTimeout = 30 * 1000 * 1000

-- JavaScript content type.
jsContentType :: ByteString
jsContentType = "text/javascript;charset=utf-8"

-- HTML content type.
htmlContentType :: ByteString
htmlContentType = "text/html;charset=utf-8"

-- Cookie name used for session ID.
cnSessionId :: ByteString
cnSessionId = "sessionId"

-- Make the session cookie.
-- TODO: Technically need UTF8 & URL-encoding for the sessionId parameter?!?
mkSessionCookie :: ByteString -> SetCookie
mkSessionCookie sessionId = SetCookie cnSessionId sessionId Nothing Nothing Nothing True

-- Empty "OK" response.
emptyOKResponse :: Response
emptyOKResponse = ResponseBuilder statusOK [] mempty

-- "Forbidden" response.
forbiddenResponse :: Response
forbiddenResponse = ResponseBuilder statusForbidden [] (fromByteString "Forbidden")

-- Index response.
indexResponse :: ServerState -> ResponseHeaders -> Response
indexResponse serverState responseHeaders = ResponseBuilder statusOK (headerContentType htmlContentType : responseHeaders) $ renderHtmlBuilder $ indexHtml applicationTitle resourceBundles
  where
    applicationTitle = L.get ssApplicationTitle serverState
    resourceBundles = L.get ssBootResourceBundles serverState

-- Bootstrap HTML page.
indexHtml :: Text -> [ResourceBundle] -> H4.Html
indexHtml applicationTitle resourceBundles =
  H4.html $ do
    H4.head $ do
      H4.title $ toHtml applicationTitle
      H4.meta ! A.httpEquiv "Content-Type" ! A.content (unsafeByteStringValue htmlContentType)
      forM_ resourceBundles $ \resourceBundle ->
        sequence_ $ mkHeadMerge resourceBundle
    H4.body $
      H4.div ! A.id "i0" $ mempty

-- Try to parse a text via UTF-8 encoding.
parseOnlyText :: Parser a -> Text -> Maybe a
parseOnlyText p s =
  case AP.parseOnly p $ TE.encodeUtf8 s of
    Left _ -> Nothing
    Right i -> Just i

-- Convert JSON encoded states to a mapping.
convertStateUpdates :: ByteString -> HashMap WidgetId Value
convertStateUpdates json =
  case AP.parseOnly AEP.value json of
    Left _ ->
      H.empty -- Error parsing; ignore.
    Right (Object o) ->
      H.fromList $ mapMaybe f $ M.toList o
    Right _ ->
      H.empty -- Invalid format; ignore.
  where
    f (k,v) =
      fmap (\i -> (i,v)) $ parseOnlyText widgetIdParser k

-- Callback server part.
callback :: ServerState -> Request -> ClientSession -> Text -> Iteratee ByteString IO Response
callback serverState request clientSession callbackIdStr =
  handle $ parseOnlyText callbackIdParser callbackIdStr
  where
    handle :: Maybe CallbackId -> Iteratee ByteString IO Response
    handle Nothing = return forbiddenResponse
    handle (Just callbackId) = do
      -- Post body contains URL-encoded data.
      (params, _) <- parseRequestBody lbsSink request
      let stateJson = fromMaybe "{}" $ lookup "state" params
      -- Get the state update portion of the form data.
      let stateUpdates = convertStateUpdates stateJson
      -- Handle the callback
      liftIO $ handleCallback serverState clientSession callbackId stateUpdates
      return emptyOKResponse

-- Long polling handler.
poll :: ServerState -> ClientSession -> Iteratee ByteString IO Response
poll serverState clientSession = do
  command <- liftIO $ readCommandWithTimeout serverState clientSession longPollTimeout
  let command_ = fromMaybe "" command
  return $ ResponseBuilder statusOK [headerContentType jsContentType] $ fromByteString command_

-- Generate SetCookie session header if necessary.
generateSessionSetCookie :: Maybe SessionId -> ClientSession -> Maybe SetCookie
generateSessionSetCookie Nothing clientSession = Just $ mkSessionCookie $ getSessionId clientSession
generateSessionSetCookie (Just sid) clientSession | (sid == getSessionId clientSession) = Nothing
                                                  | otherwise = Just $ mkSessionCookie $ getSessionId clientSession

-- Serve a bundle.
serveBundle :: ClientSession -> [Text] -> Iteratee ByteString IO Response
serveBundle _ [] = return forbiddenResponse
serveBundle clientSession (bundleId:path) = do
  clientSessionStateRef <- liftIO $ readIORef (snd clientSession)
  let serverSessionState = L.get cssClientSessionState clientSessionStateRef
  case lookupResource bundleId path serverSessionState of
    Nothing ->
      return forbiddenResponse
    Just contents ->
      return $ ResponseBuilder statusOK [] $ fromByteString contents

-- Warp server.
mkWaiApplication :: ServerState -> W.Application
mkWaiApplication serverState = loop
  where
    loop :: Request -> Iteratee ByteString IO Response
    loop request = do
      -- Extract the cookies.
      let cookies =
            parseCookies $
            fromMaybe "" $
            lookup "Cookie" $ requestHeaders request
      -- Find or create session.
      let sessionId = lookup cnSessionId cookies
      clientSession <- liftIO $ getSession serverState sessionId

      -- Detect if we've created/replaced the session.
      let sessionSetCookie = generateSessionSetCookie sessionId clientSession

      -- Generate response headers.
      let responseHeaders =
            case sessionSetCookie of
              Nothing -> [ ]
              Just s -> [ headerSetCookie s ]

      -- Process the request
      case pathInfo request of
        [] -> return $ indexResponse serverState responseHeaders
        ["poll"] -> poll serverState clientSession
        ["callback",cid] -> callback serverState request clientSession cid
        ("bundles":bundlePath) -> serveBundle clientSession bundlePath
        _  -> return forbiddenResponse