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
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
|
{-# Language QuasiQuotes #-}
module Fig.Web where
import Fig.Prelude
import System.Random (randomRIO)
import Control.Monad (unless)
import Control.Lens (use, (^?), Ixed (..))
import qualified Control.Concurrent.Chan as Chan
import qualified Control.Concurrent.MVar as MVar
import Data.Maybe (mapMaybe)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as Text.L
import qualified Data.ByteString.Base64 as BS.Base64
import qualified Data.Set as Set
import qualified Network.Wai as Wai
import qualified Network.Wai.Middleware.Static as Wai.Static
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.WebSockets as WS
import qualified Web.Scotty as Sc
import Fig.Utils.SExpr
import Fig.Bus.Client
import Fig.Web.Utils
import Fig.Web.Auth
import Fig.Web.State
import qualified Fig.Web.DB as DB
import qualified Fig.Web.LDAP as LDAP
data LiveEvent
= LiveEventOnline !(Set.Set Text)
| LiveEventOffline !(Set.Set Text)
deriving (Show, Eq, Ord)
server :: Config -> (Text, Text) -> IO ()
server cfg busAddr = do
log $ "Web server running on port " <> tshow cfg.port
liveEvents <- Chan.newChan @LiveEvent
currentlyLive <- MVar.newMVar Set.empty
busClient busAddr
(\cmds -> do
log "Connected to bus!"
cmds.subscribe [sexp|(monitor twitch stream online)|]
Warp.run cfg.port =<< app cfg cmds liveEvents currentlyLive
)
(\_cmds d -> do
case d of
SExprList (ev:rest)
| ev == [sexp|(monitor twitch stream online)|] -> do
let live = mapMaybe (\case SExprString s -> Just s; _other -> Nothing) rest
let new = Set.fromList live
old <- MVar.swapMVar currentlyLive new
let online = Set.difference new old
let offline = Set.difference old new
unless (Set.null online) . Chan.writeChan liveEvents $ LiveEventOnline online
unless (Set.null offline) . Chan.writeChan liveEvents $ LiveEventOnline offline
_other -> log $ "Invalid event: " <> tshow d
)
(pure ())
sexprStr :: Text -> SExpr
sexprStr = SExprString . BS.Base64.encodeBase64 . encodeUtf8
app :: Config -> Commands IO -> Chan.Chan LiveEvent -> MVar.MVar (Set.Set Text) -> IO Wai.Application
app cfg cmds liveEvents currentlyLive = do
log "Connecting to database..."
db <- DB.connect cfg
log "Connected! Server active."
st <- stateRef
Sc.scottyApp do
Sc.middleware $ Wai.Static.staticPolicy $ Wai.Static.addBase cfg.assetPath
Sc.get "/register" do
Sc.redirect "/register.html"
Sc.get "/unauthorized" do
Sc.status status401
Sc.text $ mconcat
[ "your request was rejected because that endpoint requires authentication\n"
, "you can log in by POSTing your credentials to https://auth.colonq.computer/api/firstfactor\n"
, "for example:\n"
, " curl https://auth.colonq.computer/api/firstfactor \\\n"
, " --header \"Content-Type: application/json\" \\\n"
, " --request POST \\\n"
, " --data '{\"username\":\"AzureDiamond\",\"password\":\"hunter2\"}' \\\n"
, " --cookie-jar cookies.txt\n"
, "this will write a cookie called \"authelia_session\" to cookies.txt\n"
, "send this cookie along with your requests to use the secure endpoints\n"
, "for example:\n"
, " curl https://secure.colonq.computer --cookie cookies.txt\n"
]
Sc.get "/api/register" $ authed cfg \auth -> do
let user = Text.toLower auth.name
LDAP.resetUserPassword cfg user auth.id >>= \case
Nothing -> do
log "Failed to register user"
Sc.status status500
Sc.text "failed to register"
Just pass -> do
log "Successfully registered user, responding..."
Sc.text . Text.L.fromStrict $ user <> " " <> pass
Sc.get "/api/check" $ authed cfg \auth -> do
Sc.json @[Text] [auth.id, auth.name]
Sc.put "/api/buffer" do
buf <- withState st $ use buffer
Sc.text $ Text.L.fromStrict buf
Sc.get "/api/motd" do
DB.get db "motd" >>= \case
Nothing -> Sc.text ""
Just val -> Sc.text . Text.L.fromStrict $ decodeUtf8 val
Sc.get "/api/catchphrase" do
let catchphrases =
[ "vtuber (male)"
, "man of letters"
, "cool guy, online"
, "internet clown man"
, "professional emacs fan"
, "web freak"
, "guy who really likes programming"
, "i use nixos btw"
, "(are these funny or cringe or both?)"
, "haha yay"
, "Joel"
] :: [Text]
i <- randomRIO (0, length catchphrases - 1)
case catchphrases ^? ix i of
Nothing -> Sc.text "man of letters"
Just val -> Sc.text $ Text.L.fromStrict val
Sc.get "/api/user/:name" do
name <- Text.toLower <$> Sc.pathParam "name"
DB.get db ("user:" <> encodeUtf8 name) >>= \case
Nothing -> do
Sc.status status404
Sc.text "user not found"
Just val -> Sc.text . Text.L.fromStrict $ decodeUtf8 val
Sc.post "/api/redeem" do
me <- Text.toLower <$> Sc.formParam "ayem"
name <- Sc.formParam "name"
input <- Sc.formParamMaybe "input"
liftIO $ cmds.publish [sexp|(frontend redeem incoming)|]
$ mconcat
[ [ sexprStr me
, sexprStr name
]
, maybe [] ((:[]) . sexprStr) input
]
Sc.text "it worked"
Sc.get "/api/songs" do
DB.hvals db "songnames" >>= \case
Nothing -> do
Sc.status status404
Sc.text "no sounds found :("
Just songs -> Sc.text . Text.L.fromStrict . pretty . SExprList @Void $ SExprString . decodeUtf8 <$> songs
Sc.get "/api/song/:hash" do
hash <- Sc.pathParam "hash"
DB.hget db "songnotes" hash >>= \case
Nothing -> do
Sc.status status404
Sc.text "song not found"
Just val -> Sc.text . Text.L.fromStrict $ decodeUtf8 val
Sc.get "/api/poke/:name" do
target <- encodeUtf8 . Text.toLower <$> Sc.pathParam "name"
inbox <- fromMaybe [] <$> DB.smembers db ("pokeinbox:" <> target)
Sc.text . Text.L.fromStrict . pretty . SExprList @Void $ sexprStr . decodeUtf8 <$> inbox
Sc.post "/api/poke/:name" do
me <- encodeUtf8 . Text.toLower <$> Sc.formParam "ayem"
target <- encodeUtf8 . Text.toLower <$> Sc.pathParam "name"
DB.sismember db ("pokeinbox:" <> me) target >>= \case
True -> do
log . tshow $ "handshake between " <> me <> " and " <> target <> " complete!"
DB.srem db ("pokeinbox:" <> target) [me]
DB.srem db ("pokeinbox:" <> me) [target]
Sc.text "complete"
False -> do
log . tshow $ "partial handshake from " <> me <> " to " <> target
DB.sadd db ("pokeinbox:" <> target) [me]
Sc.text "partial"
Sc.get "/api/sentiment" do
s <- DB.get db "sentiment" >>= \case
Nothing -> pure "0"
Just x -> pure x
Sc.text . Text.L.fromStrict . decodeUtf8 $ s
Sc.post "/api/sentiment/green" do
DB.incr db "sentiment"
Sc.post "/api/sentiment/red" do
DB.decr db "sentiment"
Sc.get "/api/circle" do
live <- liftIO $ MVar.readMVar currentlyLive
Sc.text . Text.L.fromStrict . pretty . SExprList @Void $ SExprString <$> Set.toList live
websocket "/api/circle/events" \conn -> do
c <- Chan.dupChan liveEvents
forever do
ev <- liftIO $ Chan.readChan c
WS.sendTextData conn $ case ev of
LiveEventOnline online ->
pretty $ SExprList @Void
[ SExprString "online"
, SExprList $ SExprString <$> Set.toList online
]
LiveEventOffline offline ->
pretty $ SExprList @Void
[ SExprString "offline"
, SExprList $ SExprString <$> Set.toList offline
]
Sc.notFound do
Sc.text "not found"
|
