Wai.hs

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

import           Blaze.ByteString.Builder (fromByteString, toByteString)
import           Control.Concurrent (threadDelay)
import           Control.Concurrent.Chan (newChan, writeChan)
import           Control.DeepSeq.ByteString ()
import           Control.Monad (forM_, forever, void)
import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Trans.Resource (resourceForkIO)
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 qualified Data.ByteString as B
import           Data.Conduit (ResourceT)
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as H
import           Data.IORef (readIORef)
import qualified Data.Label as L
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, readCommand, 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, lbsBackEnd)
import           Network.Wai.EventSource (eventSourceApp, ServerEvent(..))
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)

-- Keep-alive interval for events.
eventSourceKeepAlive :: Int
eventSourceKeepAlive = 5 * 1000 * 1000

-- 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 $ H.toList o
    Right _ ->
      H.empty -- Invalid format; ignore.
  where
    f (k,v) =
      fmap (\i -> (i,v)) $ parseOnlyText widgetIdParser k

-- Callback server part.
callback :: Request -> ClientSession -> Text -> ResourceT IO Response
callback request clientSession callbackIdStr =
  handle $ parseOnlyText callbackIdParser callbackIdStr
  where
    handle :: Maybe CallbackId -> ResourceT IO Response
    handle Nothing = return forbiddenResponse
    handle (Just callbackId) = do
      -- Post body contains URL-encoded data.
      (params, _) <- parseRequestBody lbsBackEnd 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 clientSession callbackId stateUpdates
      return emptyOKResponse

-- Long polling handler.
poll :: ClientSession -> Request -> ResourceT IO Response
poll clientSession request = do
  evChan <- liftIO $ newChan
  -- Introduce a thread which issues keep-alive events.
  void $ resourceForkIO $ forever $ liftIO $ do
    threadDelay eventSourceKeepAlive
    writeChan evChan $ CommentEvent $ fromByteString "keep-alive"
  -- Introduce a thread which transforms commands from client session to events.
  void $ resourceForkIO $ forever $ liftIO $ do
    c <- readCommand clientSession
    writeChan evChan $ ServerEvent Nothing Nothing
      [ fromByteString $ B.map escape c ]
  -- Serve the events.
  eventSourceApp evChan request
  where
    -- Replace all non-printable characters with a space.
    escape c | c < 0x20  = 0x20
    escape c | otherwise = c

-- 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] -> ResourceT 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 = 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 clientSession request
        ["callback",cid] -> callback request clientSession cid
        ("bundles":bundlePath) -> serveBundle clientSession bundlePath
        _  -> return forbiddenResponse