content: {-# LANGUAGE DataKinds        #-}
  {-# LANGUAGE QuasiQuotes      #-}
  {-# LANGUAGE TypeApplications #-}
  {-# LANGUAGE TypeOperators    #-}
  
  module Web.Suavemente.Core where
  
  import           Control.Applicative (liftA2)
  import           Control.Concurrent.STM.TVar (TVar, writeTVar)
  import           Control.Monad.Except (throwError)
  import           Control.Monad.IO.Class (liftIO)
  import           Control.Monad.STM (atomically)
  import           Control.Monad.State (evalStateT)
  import           Data.Aeson (Value, decode, Result (..))
  import           Data.Aeson.Types (Parser, parse)
  import qualified Data.ByteString.Char8 as B
  import qualified Data.Map.Strict as M
  import           Data.Proxy (Proxy (..))
  import           Network.Wai.Handler.Warp (run)
  import           Network.WebSockets (Connection, receiveData, sendTextData)
  import           Servant (Get, Handler, Capture, (:<|>)(..), (:>), serve, err404)
  import           Servant.API.WebSocket (WebSocket)
  import           Servant.HTML.Blaze (HTML)
  import qualified Streaming as S
  import qualified Streaming.Prelude as S
  import           Text.Blaze (preEscapedString, Markup, ToMarkup (..))
  import           Text.Blaze.Renderer.String (renderMarkup)
  import           Text.InterpolatedString.Perl6 (qc, q)
  import           Web.Suavemente.Types
  
  
  ------------------------------------------------------------------------------
  -- | Get a 'String' representation of a markup-able type. Useful for
  -- constructing elements via quasiquotation.
  showMarkup :: ToMarkup a => a -> String
  showMarkup = renderMarkup . toMarkup
  
  
  ------------------------------------------------------------------------------
  -- | EXPLODE IF PARSING FAILS
  fromResult :: Result a -> a
  fromResult (Success a) = a
  fromResult (Error s) = error s
  
  
  ------------------------------------------------------------------------------
  -- | Construct an '_iFold' field for 'Input's.
  getEvents
      :: (Value -> Parser a)
      -> TVar a  -- ^ The underlying 'TVar' to publish changes to.
      -> String  -- ^ The name of the HTML input.
      -> IO ()   -- ^ Publish a change notification.
      -> S.Stream (S.Of ChangeEvent) IO ()
      -> S.Stream (S.Of ChangeEvent) IO ()
  getEvents p t n update
    = S.mapMaybeM (
      \a@(ChangeEvent i z) ->
         case i == n of
            True  -> do
              liftIO . atomically . writeTVar t . fromResult $ parse p z
              update
              pure Nothing
            False -> pure $ Just a
             )
  
  
  ------------------------------------------------------------------------------
  -- | HTML code to inject into all 'Suave' pages.
  htmlPage :: (a -> Markup) -> String -> a -> Markup
  htmlPage pp res a = preEscapedString $
    [q|
    <style>
    </style>|]
    ++
    [q|
    <script>
      // from https://code.lengstorf.com/get-form-values-as-json/
      const isCheckbox = e => e.type === 'checkbox';
      const isMultiSelect = e => e.options && e.multiple;
      const getSelectValues = options => [].reduce.call(options, (values, option) => {
        return option.selected ? values.concat(option.value) : values;
      }, []);
  
  
      let ws = new WebSocket("ws://localhost:8080/|] ++ res ++ [q|/ws");
  
      const keepAlive = () => {
        ws.send(JSON.stringify({}));
        setTimeout(keepAlive, 1000);
      };
  
      ws.onopen = e => keepAlive();
      ws.onmessage = e => document.getElementById("result").innerHTML = e.data;
  
      const onChangeFunc = e => {
        let element = e.target;
        let result = null;
        if (isCheckbox(element)) {
          result = element.checked;
        } else if (isMultiSelect(element)) {
          result = getSelectValues(element);
        } else if (element.type === 'range') {
          result = parseFloat(element.value);
        } else {
          result = element.value;
        }
  
        if (result !== null) {
          ws.send(JSON.stringify({ "element": element.id, "payload": result }));
        }
      }
    </script>
    |]
    ++
    [qc|
    <div id="result">{renderMarkup $ pp a}</div>
    <table>
    |]
  
  
  ------------------------------------------------------------------------------
  -- | The API for 'Suave' pages.
  type API = Get '[HTML] Markup
        :<|> "" :> "ws" :> WebSocket
  
  
  ------------------------------------------------------------------------------
  -- | The API for 'Suavely' pages.
  type API2 = Capture "resource" String :> Get '[HTML] Markup
         :<|> Capture "resource" String :> "ws" :> WebSocket
  
  
  ------------------------------------------------------------------------------
  -- | Run a 'Suave' computation by spinning up its webpage at @localhost:8080@.
  suavemente :: (a -> Markup) -> Suave a -> IO ()
  suavemente pp w = do
    let ws = M.singleton "" $ SomeSuave pp w
    run 8080
      . serve (Proxy @API)
      $ htmlHandler ws "" :<|> socketHandler ws ""
  
  
  ------------------------------------------------------------------------------
  -- | Run a 'Suave' computation by spinning up its webpage at @localhost:8080@.
  suavementely :: M.Map String SomeSuave -> IO ()
  suavementely w = do
    run 8080
      . serve (Proxy @API2)
      $ htmlHandler w :<|> socketHandler w
  
  
  ------------------------------------------------------------------------------
  -- | 'Handler' endpoint for responding to 'Suave''s websockets.
  socketHandler
      :: M.Map String SomeSuave
      -> String
      -> Connection
      -> Handler ()
  socketHandler ws s c =
    case M.lookup s ws of
      Nothing -> throwError err404
      Just (SomeSuave pp w) -> liftIO $ do
        Input _ f a <- atomically $ evalStateT (suavely w) 0
        S.effects
          . f (sendTextData c . B.pack . renderMarkup . pp =<< atomically a)
          . S.mapM (liftA2 (>>) print pure)
          . S.mapMaybe id
          . S.repeatM
          . fmap decode
          $ receiveData c
  
  
  ------------------------------------------------------------------------------
  -- | Serve the static HTML.
  htmlHandler :: M.Map String SomeSuave -> String -> Handler Markup
  htmlHandler ws res =
    case M.lookup res ws of
      Nothing -> throwError err404
      Just (SomeSuave pp w) -> liftIO $ do
        Input html _ a <- atomically $ evalStateT (suavely w) 0
        a0 <- atomically a
        pure $ htmlPage pp res a0 <> html
  
  