{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Handlers ( -- , submitImpl statusImpl -- , relintImpl , stateImpl , AdminOverview(..) , MapService(..),relintImpl,realtimeImpl) where import Universum import CheckDir (DirResult (dirresultMaps)) import CheckMap (MapResult (..)) import Control.Concurrent.STM (TQueue, dupTChan, readTChan, writeTQueue) import Data.Aeson (ToJSON (..), (.=)) import qualified Data.Aeson as A import qualified Data.Aeson.Key as A import Data.Coerce (coerce) import qualified Data.Map as M import Network.WebSockets (PendingConnection, acceptRequest, rejectRequest, sendTextData, withPingThread) import Servant (Handler, err404, throwError) import Server (JobStatus (..), Org (orgUrl), RemoteRef (reponame), ServerState, Sha1, adjustedWebPath, getJobStatus, unState) import Worker (Job (Job)) -- | an info type wrapped around the server state, to carry serialisation instances. newtype AdminOverview = AdminOverview { unAdminOverview :: ServerState } newtype MapService = MapService { unMapService :: ServerState } instance ToJSON MapService where toJSON (MapService state) = toJSON . map orgObject $ view unState state where orgObject (org, statuses) = A.object . mapMaybe worldObject $ M.elems statuses where worldObject (remote, _current, result) = case result of Just (Linted res rev _) -> Just (A.fromText (reponame remote) .= M.mapWithKey (mapInfo rev) (dirresultMaps res)) _ -> Nothing mapInfo rev mappath MapResult { .. } = A.object [ "badges" .= mapresultBadges -- TODO: type-safe url library for adding the slash? , "jitsi" .= mapresultJitsis , "url" .= (orgUrl org <> adjustedWebPath rev org <> "/" <> toText mappath) ] statusImpl :: MVar ServerState -> Text -> Sha1 -> Handler (Org True, RemoteRef, JobStatus, Maybe JobStatus) statusImpl state orgslug sha1 = do status <- liftIO $ getJobStatus state orgslug sha1 case status of Just stuff -> pure stuff Nothing -> throwError err404 -- | since there are multiple apis that just get state information … stateImpl :: forall s . Coercible s ServerState => MVar ServerState -> Handler s stateImpl state = readMVar state <&> coerce relintImpl :: TQueue Job -> MVar ServerState -> Text -> Sha1 -> Handler Text relintImpl queue state orgslug sha1 = liftIO $ getJobStatus state orgslug sha1 >>= \case Nothing -> pure "there isn't a job here to restart" Just (org, ref, _oldjob, _veryoldjob) -> do atomically $ writeTQueue queue (Job ref org) pure "hello" realtimeImpl :: MVar ServerState -> Text -> Sha1 -> PendingConnection -> Handler () realtimeImpl state orgslug sha1 pending = liftIO (getJobStatus state orgslug sha1) >>= \case Just (_org, _ref, Linted _ _ (_, realtime), _) -> do conn <- liftIO $ acceptRequest pending incoming <- atomically $ dupTChan realtime liftIO $ withPingThread conn 30 pass $ forever $ do next <- atomically $ readTChan incoming sendTextData conn (A.encode next) _ -> liftIO $ rejectRequest pending "no!"