content: {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE TemplateHaskell #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE TypeOperators #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  module Main where
  
  import Control.Concurrent (forkIO, threadDelay)
  import Control.Concurrent.STM (TVar, atomically, newTVarIO, readTVar, retry, writeTVar)
  import Control.Monad (forever, void)
  import Control.Monad.IO.Class (liftIO)
  import Control.Monad.Loops (iterateM_)
  import Control.Monad.Reader (ask)
  import Control.Monad.State (put)
  import Data.Acid (AcidState, Query, Update, makeAcidic, openLocalState, query, update)
  import Data.Binary (decode, encode)
  import Data.Foldable (toList)
  import Data.SafeCopy (base, deriveSafeCopy)
  import Data.Sequence (Seq, ViewR ((:>)), (|>))
  import qualified Data.Sequence as S (empty, filter, singleton, viewr)
  import Data.Text (Text)
  import Message
    ( C2SMsg (..),
      Commit (..),
      CommitId (..),
      S2CMsg (..),
      commitId,
    )
  import Network.WebSockets
    ( Connection,
      DataMessage (Binary, Text),
      acceptRequest,
      receiveDataMessage,
      runServer,
      sendDataMessage,
      sendPing,
    )
  import Servant (Get, JSON, Proxy (..), Server, (:>))
  import System.Environment (getEnv)
  import Type (Doc (..), Stroke (..))
  
  getLast :: Seq a -> Maybe a
  getLast s =
    case S.viewr s of
      _ :> x -> Just x
      _ -> Nothing
  
  -- orphans.
  
  $(deriveSafeCopy 0 'base ''CommitId)
  
  $(deriveSafeCopy 0 'base ''Commit)
  
  data DocState = DocState
    { _docStateCommits :: Seq Commit,
      _docStateCurrentDoc :: Seq (CommitId, Int, [(Double, Double)])
    }
    deriving (Show)
  
  $(deriveSafeCopy 0 'base ''DocState)
  
  writeState :: DocState -> Update DocState ()
  writeState = put
  
  queryState :: Query DocState DocState
  queryState = ask
  
  $(makeAcidic ''DocState ['writeState, 'queryState])
  
  handler ::
    Connection ->
    AcidState DocState ->
    TVar DocState ->
    IO ()
  handler conn acid ref = forever $ do
    dmsg <- receiveDataMessage conn
    case dmsg of
      Text _ _ -> pure ()
      Binary lbs -> do
        case decode lbs of
          NewStroke (hsh, coords) -> do
            s' <-
              atomically $ do
                DocState commits dat <- readTVar ref
                let (commits', dat') = case getLast commits of
                      Just commitLast ->
                        let r = commitId commitLast
                            commit = Add (r + 1) coords
                         in (commits |> commit, dat |> (r + 1, hsh, coords))
                      Nothing ->
                        let commit = Add 1 coords
                         in (S.singleton commit, S.singleton (1, hsh, coords))
                    s' = DocState {_docStateCommits = commits', _docStateCurrentDoc = dat'}
                writeTVar ref s'
                pure s'
            update acid $ WriteState s'
          DeleteStrokes is -> do
            s' <-
              atomically $ do
                DocState commits dat <- readTVar ref
                let dat' = S.filter (\(i, _, _) -> not (i `elem` is)) dat
                    commits' = case getLast commits of
                      Just commitLast ->
                        let r = commitId commitLast
                            commit = Delete (r + 1) is
                         in commits |> commit
                      Nothing -> S.singleton (Delete 1 is)
                    s' = DocState {_docStateCommits = commits', _docStateCurrentDoc = dat'}
                writeTVar ref s'
                pure s'
            update acid $ WriteState s'
          SyncRequest (s, e) -> do
            if s == 0
              then do
                -- for initializing a client
                DocState _ currDoc <- atomically $ readTVar ref
                let commits = toList $ fmap (\(cid, _, strk) -> Add cid strk) currDoc
                    msg = DataStrokes commits
                sendDataMessage conn (Binary (encode msg))
              else do
                -- for updating a already-initialized client
                DocState commits _ <- atomically $ readTVar ref
                let commits' =
                      toList $
                        S.filter (\c -> let i = commitId c in i > s && i <= e) commits
                    msg = DataStrokes commits'
                sendDataMessage conn (Binary (encode msg))
  
  type API = "doc" :> Get '[JSON] Doc
  
  api :: Proxy API
  api = Proxy
  
  server :: TVar DocState -> Server API
  server var = do
    s <- liftIO $ atomically $ readTVar var
    let doc =
          Doc $
            map (\(i, _, xys) -> Stroke i xys) $
              toList (_docStateCurrentDoc s)
    pure doc
  
  second :: Int
  second = 1000000
  
  pingPeriod :: Int
  pingPeriod = 1 * second
  
  -- | ping-pong every pingPeriod.
  ping :: Connection -> IO ()
  ping conn = forever $ do
    threadDelay pingPeriod
    sendPing conn ("ping" :: Text)
  
  main :: IO ()
  main = do
    hostAddress <- getEnv "HOSTADDRESS"
    hostWSPort <- read <$> getEnv "WSPORT"
    putStrLn ("HOSTADDRESS = " ++ hostAddress)
    putStrLn ("WSPORT = " ++ show hostWSPort)
    acid <- openLocalState (DocState S.empty S.empty)
    s <- query acid QueryState
    ref <- newTVarIO s
    void $
      runServer hostAddress hostWSPort $ \pending -> do
        conn <- acceptRequest pending
        putStrLn "websocket connected"
        void $ forkIO $ ping conn
        -- synchronization
        void $ forkIO $ handler conn acid ref
        void $
          flip iterateM_ 0 $ \r -> do
            r' <-
              atomically $ do
                DocState commits _ <- readTVar ref
                case getLast commits of
                  Just commit -> let r' = commitId commit in if (r' <= r) then retry else pure r'
                  Nothing -> retry
            let msg = RegisterStroke r'
            sendDataMessage conn (Binary (encode msg))
            pure r'
  