1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
|
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Handlers (
-- , submitImpl
statusImpl
-- , relintImpl
, stateImpl
, AdminOverview(..)
, MapService(..),relintImpl,realtimeImpl) where
import Universum hiding (view)
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 Lens.Micro.Platform (view)
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!"
|
