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
|
module Fig.Web.Module.Puzzle
( secure
) where
import Fig.Prelude
import qualified Data.Map.Strict as Map
import qualified Data.Aeson as Aeson
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import Fig.Web.Utils
import Fig.Web.Types
import Fig.Web.Auth
import Fig.Web.DB
data Puzzle = Puzzle
{ pid :: Text
, name :: Text
, author :: Text
, authorid :: Text
, body :: Text
, checker :: Text
} deriving (Show, Generic)
instance Aeson.ToJSON Puzzle
newPuzzlePid :: forall m. (MonadIO m, MonadCatch m) => m Text
newPuzzlePid = do
uuid <- liftIO UUID.nextRandom
pure $ UUID.toText uuid
puzzlePidKey :: Text -> ByteString
puzzlePidKey pid = "puzzle:" <> encodeUtf8 pid
puzzleKey :: Puzzle -> ByteString
puzzleKey p = puzzlePidKey p.pid
savePuzzle :: MonadIO m => DB -> Puzzle -> m ()
savePuzzle db p = do
sadd db "puzzleids" [encodeUtf8 p.pid]
hmset db (puzzleKey p)
[ ("pid", encodeUtf8 p.pid)
, ("name", encodeUtf8 p.name)
, ("author", encodeUtf8 p.author)
, ("authorid", encodeUtf8 p.authorid)
, ("body", encodeUtf8 p.body)
, ("checker", encodeUtf8 p.checker)
]
loadPuzzle :: MonadIO m => DB -> Text -> m (Maybe Puzzle)
loadPuzzle db p = do
m <- hgetall db $ puzzlePidKey p
pure $ do
let field nm = decodeUtf8 <$> Map.lookup nm m
pid <- field "pid"
if pid == p
then do
name <- field "name"
author <- field "author"
authorid <- field "authorid"
body <- field "body"
checker <- field "checker"
Just Puzzle {..}
else Nothing
deletePuzzle :: MonadIO m => DB -> Text -> m ()
deletePuzzle db p = do
srem db "puzzleids" [encodeUtf8 p]
del db [puzzlePidKey p]
allPuzzles :: MonadIO m => DB -> m [Text]
allPuzzles db = smembers db "puzzleids" >>= \case
Nothing -> pure []
Just xs -> pure $ decodeUtf8 <$> xs
secure :: SecureModule
secure a = do
onGet "/api/puzzle" do
puzzles <- allPuzzles a.db
respondJSON puzzles
onGet "/api/puzzle/:pid" do
pid <- pathParam "pid"
loadPuzzle a.db pid >>= \case
Nothing -> do
status status404
respondText "no such puzzle"
Just p -> respondJSON p
onDelete "/api/puzzle/:pid" do
pid <- pathParam "pid"
deletePuzzle a.db pid
onPost "/api/puzzle" $ authed a \creds -> do
log "Creating puzzle"
let author = creds.user
let authorid = creds.twitchId
pid <- newPuzzlePid
log $ "pid: " <> tshow pid
name <- formParam "name"
body <- formParam "body"
checker <- formParam "checker"
savePuzzle a.db Puzzle {..}
respondText pid
|
