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
|
{-# Language QuasiQuotes #-}
module Fig.Frontend where
import Fig.Prelude
import System.Random (randomRIO)
import Control.Lens (use, (^?), Ixed (..))
import qualified Data.Text as Text
import qualified Data.Text.Lazy as Text.L
import qualified Data.ByteString.Base64 as BS.Base64
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 Web.Scotty as Sc
import Fig.Utils.SExpr
import Fig.Bus.Client
import Fig.Frontend.Utils
import Fig.Frontend.Auth
import Fig.Frontend.State
import qualified Fig.Frontend.DB as DB
server :: Config -> (Text, Text) -> IO ()
server cfg busAddr = do
log $ "Frontend server running on port " <> tshow cfg.port
busClient busAddr
(\cmds -> do
log "Connected to bus!"
Warp.run cfg.port =<< app cfg cmds
)
(\_ _ -> pure ())
(pure ())
sexprStr :: Text -> SExpr
sexprStr = SExprString . BS.Base64.encodeBase64 . encodeUtf8
app :: Config -> Commands IO -> IO Wai.Application
app cfg cmds = 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 "/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/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.notFound do
Sc.text "not found"
|
