~philipwhite/webpad

ref: 13eb1e12ca08a0ce4ba6c72193ef4db70bbedb37 webpad/Main.hs -rw-r--r-- 26.4 KiB
13eb1e12 — Linux User Make username use stronger type 2 years ago
                                                                                
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
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
{-# LANGUAGE OverloadedStrings, LambdaCase, RecordWildCards #-}
module Main where

import Web.Scotty
import Web.Scotty.Cookie
import Web.Cookie
import Network.Wai.Middleware.Static
import Network.HTTP.Types.Status

import Lucid.Html5
import Lucid.Base

import Data.Aeson
import Data.Aeson.Types

import Control.Applicative
import Control.Monad (forM_)
import Control.Monad.IO.Class
import Data.Functor ((<&>))
import Data.Function ((&))
import Data.Maybe (isJust, isNothing, listToMaybe)
import Data.Void
import Data.Word
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.Char

import Database.SQLite.Simple
import Database.SQLite.Simple.FromRow
import Database.SQLite.Simple.FromField
import Database.SQLite.Simple.ToField

import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import qualified Data.Text.Lazy as LazyText
import qualified Data.Text.Lazy.Encoding as LazyEncoding
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.ByteString.Base64 (encodeBase64)
import qualified Data.ByteString as BS
import Text.Hex (encodeHex)

import Crypto.BCrypt
import Crypto.Random

import System.Directory
import System.Environment
import System.Exit
import System.IO

--
-- User Interface
--

usersPage :: [UserRow] -> CsrfToken -> Html ()
usersPage users _ = page "Admin" "/admin.css" $ do
    h1_ "Users"
    p_ "Users with inverted colors are administrators"
    ul_ [id_ "users-list"] $ mapM_ (userToItem) users
    hr_ []
    ul_ $ do
        li_ (toHtml usernameRequirement)
        li_ (toHtml passwordRequirement)
        li_ "Don't be lazy when making a password; use a password manager if possible."
    div_ [id_ "create-user-form"] $ do
        input_ [ id_ "username-field"
               , selenium_ "create-user-username"
               , type_ "text"
               , placeholder_ "username (1-50 characters)"
               , required_ ""
               , pattern_ "[1-9A-Za-z_-]{1,50}"]
        input_ [ id_ "password-field"
               , selenium_ "create-user-password"
               , type_ "password"
               , placeholder_ "password (2-50 characters)"
               , required_ ""  
               , pattern_ ".{2,50}"]
        div_ $ do
            input_ [id_ "is-admin-field",
                    type_ "checkbox",
                    selenium_ "create-user-is-admin"]
            label_ [for_ "is-admin"] "Grant Admin Privileges"
        button_ [type_ "submit",
                 onclick_ "add_user()",
                 selenium_ "create-user-submit"] "Create Registration"
    with (script_ "") [src_ "/admin.js"]

dashboardPage :: UserRow -> [Document] -> CsrfToken -> Html ()
dashboardPage (UserRow _ username isAdmin) documents csrfToken =
    page (toHtml username) "/dashboard.css" $ do
        h1_ "Home"
        form_ [method_ "POST", action_ "/logout"] $ do
            csrf_input csrfToken
            button_ [type_ "submit", selenium_ "logout-button"] "Logout"
        table_ $ tbody_ [id_ "documents-list"] $ do
            mapM_ documentToItem documents
        button_ [onclick_ "add_document()", selenium_ "add-document-button"] "Add Document"
        with (script_ "") [src_ "/dashboard.js"]

roleSelect :: RoleType -> Html ()
roleSelect roleType = select_ $ do
    let (roleTypeValue, roleTypeDisplay) = case roleType of
                                               Owner -> ("owner", "Owner")
                                               Viewer -> ("viewer", "Viewer")
                                               Editor -> ("editor", "Editor")
    option_ [value_ roleTypeValue, selected_ "", disabled_ "", hidden_ ""] roleTypeDisplay
    option_ [value_ "viewer"] "Viewer" 
    option_ [value_ "editor"] "Editor"
    option_ [value_ "owner"] "Owner"

sharePage :: [(UserId, T.Text, RoleType)] -> Document -> CsrfToken -> Html ()
sharePage roles (Document filename title public) csrfToken =
    page "Share" "/share.css" $ do
        h1_ (toHtml ("Share " <> show title))
        table_ $ tbody_ [id_ "roles-table"] $ do
            mapM_ (\((UserId userId), username, roleType) -> tr_ [id_ ("role-row-" <> userId), selenium_ ("role-" <> username)] $ do
                td_ $ toHtml username
                td_ $ with (roleSelect roleType) [oninput_ ("update_role(this, '" <> filename <> "', '" <> userId <> "')")]
                td_ $ button_ [onclick_ ("delete_role('" <> filename <> "', '" <> userId <> "')"), selenium_ ("delete-" <> username)] "delete") roles
            tr_ [id_ "new-role-row"] $ do
                td_ $ input_ [id_ "username-field", type_ "text", placeholder_ "username", selenium_ "new-role-username"]
                td_ $ with (roleSelect Viewer) [id_ "new-role-select", selenium_ "new-role-role-type"]
                td_ $ button_ [onclick_ ("add_role('" <> filename <> "')"), selenium_ "new-role-add"] "Share"
        with (script_ "") [src_ "/share.js"]

loginPage :: Bool -> CsrfToken -> Html ()
loginPage hasFailed csrfToken = page "WebPad Login" "/login.css" $ do
    form_ [method_ "POST"] $ do
        csrf_input csrfToken
        input_ [name_ "username",
                type_ "text",
                placeholder_ "username",
                autofocus_,
                selenium_ "login-username"]
        input_ [name_ "password",
                type_ "password",
                placeholder_ "password",
                selenium_ "login-password"]
        input_ [type_ "submit",
                value_ "Login",
                selenium_ "login-submit"]
        if hasFailed then
            div_ [class_ "has-failed-error"] "Username or password was incorrect"
        else pure ()

documentPage :: Document -> T.Text -> RoleType -> CsrfToken -> Html ()
documentPage (Document filename title _) body Viewer _ =
    page (toHtmlRaw ("WebPad - " <> title)) "/public_document.css" $ do
        pre_ [id_ "title-div"] (toHtml (title <> "\n" <> T.pack (take (T.length title) (repeat '='))))
        pre_ [id_ "body-div"] (toHtml body)
documentPage (Document filename title public) body role _ = 
    page (toHtmlRaw ("WebPad - " <> title)) "/index.css" $ do
        div_ [id_ "title-bar"] $ do
            input_ [id_ "title-input",
                    type_ "text",
                    placeholder_ "title",
                    oninput_ "handle_title_input()",
                    value_ title,
                    selenium_ "title"]
            if role == Owner then
                do a_ [id_ "share-link", selenium_ "share", href_ ("/share/" <> filename)] "Share"
                   label_ [selenium_ "toggle-publish"]$ do
                       let attributes = [id_ "published-checkbox",
                                         type_ "checkbox",
                                         value_ (if public then "true" else "false"),
                                         oninput_ "handle_published_input()",
                                         selenium_ "publish"]
                       input_ (if public then checked_:attributes else attributes)
                       div_ [id_ "publish-label"] "Publish"
                       div_ [id_ "unpublish-label"] "Unpublish"
            else pure ()
        textarea_ [id_ "main-textarea", 
            oninput_ "handle_input()",
            selenium_ "body"] (toHtml body)
        with (script_ "") [src_ "/index.js"]

newtype Username = Username T.Text deriving Show

instance FromJSON Username where
    parseJSON = withText "username" $ \text -> do
        if T.length text == 0 || T.length text > 50 then fail usernameRequirement
        else if not (T.all isAlphaNum text) then fail "invalid username"
        else pure (Username text)

instance ToField Username where
    toField (Username username) = toField username

data AddRole = AddRole Username RoleType deriving Show

instance FromJSON AddRole where
    parseJSON = withObject "add-role" $ \o -> AddRole <$> o .: "username" <*> o .: "role"

data PutRole = PutRole T.Text RoleType deriving Show

instance FromJSON PutRole where
    parseJSON = withObject "add-role" $ \o -> PutRole <$> o .: "userId" <*> o .: "role"

data DeleteRole = DeleteRole T.Text deriving Show

instance FromJSON DeleteRole where
    parseJSON = withObject "delete-role" $ \o -> DeleteRole <$> o .: "userId"

data UpdateDocument = UpdateDocument (Maybe T.Text) (Maybe T.Text) (Maybe Bool) deriving (Show)

instance FromJSON UpdateDocument where
    parseJSON = withObject "update-document" $ \o -> do
        newTitle <- o .:? "title"
        newBody <- o .:? "body"
        newPublicity <- o .:? "public"
        pure (UpdateDocument newTitle newBody newPublicity)

data Registration = Registration Username T.Text Bool deriving (Show)

data RoleType = Owner | Editor | Viewer deriving (Show, Eq, Enum)

instance FromField RoleType where
    fromField field = toEnum <$> fromField field

instance ToField RoleType where
    toField = toField . fromEnum

instance FromJSON RoleType where
    parseJSON = withText "role-type" $ \text -> do
        case text of
            "owner" -> pure Owner
            "editor" -> pure Editor
            "viewer" -> pure Viewer
            _ -> fail "role type must be either 0, 1, or 2"


instance FromJSON Registration where
    parseJSON = withObject "user" $ \o -> do
        username <- o .: "username"
        password <- o .: "password"
        isAdmin <- o .: "isAdmin"
        if T.length password < 2 || T.length password > 50 then fail passwordRequirement
        else return (Registration username password isAdmin)

data DeleteUser = DeleteUser T.Text

instance FromJSON DeleteUser where
    parseJSON = withObject "delete-user" $ \o -> DeleteUser <$> o .: "user_id"

data Login = Login T.Text T.Text deriving (Show)

instance FromJSON Login where
    parseJSON = withObject "login" $ \o -> do
        Login <$> o .: "username" <*> o.: "password"

newtype UserId = UserId T.Text deriving (Show, Eq)

instance ToField UserId where
    toField (UserId userId) = toField userId

instance FromField UserId where
    fromField field = UserId <$> fromField field

data UserRow = UserRow UserId T.Text Bool deriving (Show)

instance FromRow UserRow where
    fromRow = UserRow <$> field <*> field <*> field

userToItem :: UserRow -> Html ()
userToItem (UserRow (UserId userId) username isAdmin) =
    let classes = if isAdmin then "user-item admin-user-item" else "user-item" in
    li_ [id_ ("user-item-" <> userId), class_ classes] $ do
        toHtml username
        button_ [onclick_ ("delete_user('" <> userId <> "')"),
                 selenium_ ("delete-user-" <> username)] "delete"


usernameRequirement = "Username must be between 1 and 50 characters"
passwordRequirement = "Password must be between 2 and 50 characters"
loginTokenCookie = "login-token"
csrfTokenKey = "csrf-token"

page title stylesheet body = doctypehtml_ $ do
    head_ $ do
        meta_ [charset_ "UTF-8"]
        meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1.0"]
        link_ [rel_ "stylesheet", type_ "text/css", href_ stylesheet]
        with (script_ "") [src_ "/utils.js"]
        title_ title
    body_ body

selenium_ :: T.Text -> Attribute
selenium_ = makeAttribute "data-selenium"

data Document = Document T.Text T.Text Bool deriving (Show)

instance FromRow Document where
    fromRow = Document <$> field <*> field <*> ((== (1 :: Int)) <$> field)

csrf_input (CsrfToken csrfToken) = input_ [name_ "csrf-token", type_ "hidden", value_ csrfToken]

documentToItem :: Document -> Html ()
documentToItem (Document filename title public) =
    tr_ [id_ ("document-item-" <> filename)] $ do
        td_ $ a_ [href_ ("/document/" <> filename)] $ if T.length title == 0 then em_ "[No Title]" else (toHtml title)
        td_ $ if public then strong_ "published" else em_ "private"
        td_ $ button_ [onclick_ ("delete_document('" <> filename <> "')"),
                       selenium_ "delete-document-button"] "delete"

hashPolicy = slowerBcryptHashingPolicy { preferredHashCost = 9 }
withConn = withConnection "webpad.db"

authenticatedUser conn = do
    maybeLoginToken <- getCookie loginTokenCookie
    case maybeLoginToken of
        Just loginToken ->
            listToMaybe <$> liftIO (query conn "select users.id, users.username, users.is_admin \
                                               \from logins, users \
                                               \where logins.user_id = users.id \
                                               \  and identifier = ?" (Only loginToken) :: IO [UserRow])
        Nothing -> pure Nothing

maybeParam name = (Just <$> param name) `rescue` \msg -> pure Nothing

validateCsrfTokenForm :: ActionM ()
validateCsrfTokenForm = do
    maybeParamCsrfToken <- maybeParam "csrf-token"
    maybeCookieCsrfToken <- getCookie csrfTokenKey
    case (maybeParamCsrfToken, maybeCookieCsrfToken) of
        (Just paramCsrfToken, Just cookieCsrfToken) | paramCsrfToken == cookieCsrfToken -> pure ()
        _ -> do
            status unauthorized401
            finish

newtype CsrfToken = CsrfToken T.Text

data WithCsrfToken a = WithCsrfToken T.Text a

instance FromJSON a => FromJSON (WithCsrfToken a) where
    parseJSON v = WithCsrfToken
        <$> (withObject "object with csrf token" (.: "csrf-token") v)
        <*> parseJSON v

validateAndDecodeJsonData :: FromJSON a => ActionM a
validateAndDecodeJsonData = do
    contents <- body
    case eitherDecode contents of
        Right (WithCsrfToken jsonCsrfToken value) -> do
            maybeCookieCsrfToken <- getCookie csrfTokenKey
            case maybeCookieCsrfToken of
                Just cookieCsrfToken | jsonCsrfToken == cookieCsrfToken -> pure value
                _ -> do status unauthorized401; finish
        Left error -> do
            status badRequest400
            text (LazyText.pack error)
            finish


getRandomToken :: IO T.Text
getRandomToken = encodeBase64 <$> getRandomBytes 40

getRandomUserId :: IO T.Text
getRandomUserId = encodeBase64 <$> getRandomBytes 8

csrfPage :: (CsrfToken -> Html ()) -> ActionM ()
csrfPage pageGenerator = do
    csrfToken <- liftIO getRandomToken
    setCookie (makeSimpleCookie csrfTokenKey csrfToken) { setCookiePath = Just "/" }
    html $ renderText $ pageGenerator (CsrfToken csrfToken)

noCache = addHeader "Cache-Control" "private, max-age=0, no-cache, no-store"

requireAuthenticatedUser conn = do
    user <- authenticatedUser conn
    case user of
        Just userRow -> pure userRow
        _ -> redirect "/login"

getUserRole :: Connection -> T.Text -> UserId -> ActionM (Maybe RoleType)
getUserRole conn filename userId = do
     roles <- liftIO $ query conn "select type from roles \
                                  \where document = ? \
                                  \  and user_id = ?" (filename, userId)
     pure (fromOnly <$> listToMaybe roles)


data Config = Config { configPort :: !Int
                     , configDatabasePath :: !String 
                     , configFilesDirectoryPath :: !T.Text
                     } deriving (Show)

defaultConfig = Config { configPort = 8080
                       , configDatabasePath = "webpad.db"
                       , configFilesDirectoryPath = "files" }

parseArgs :: [String] -> Maybe Config
parseArgs = parseArgs' defaultConfig
    where parseArgs' config ("-port":port:rest) = parseArgs' (config { configPort = read port }) rest
          parseArgs' config ("-db":path:rest) = parseArgs' (config { configDatabasePath = path }) rest
          parseArgs' config ("-files":directory:rest) = parseArgs' (config { configFilesDirectoryPath = T.pack directory }) rest
          parseArgs' config ("-help":rest) = Nothing
          parseArgs' config ("-h":rest) = Nothing
          parseArgs' config _ = Just config

isDocumentOwner filename currentUserId conn = do
    owners <- query conn "select 1 from roles \
                         \where document = ? \
                         \and user_id = ? \
                         \and type = 2" (filename, currentUserId) :: IO [Only Int]
    pure $ null owners

main :: IO ()
main = do
    maybeConfig <- parseArgs <$> getArgs
    Config{..} <- case maybeConfig of
                     Just config -> pure config
                     Nothing -> do
                         putStrLn "WebPad server - notepad.exe for the internet"
                         putStrLn "Usage: webpad [-port <server-port> | -db <sqlite-db-path> | -files <document-files-directory> | -help | -h]"
                         exitSuccess

    conn <- open configDatabasePath
    scotty configPort $ do
        middleware $ staticPolicy (noDots >-> addBase "static")

        get "/users" $ do
            users <- liftIO (query_ conn "select id, username, is_admin from users" :: IO [UserRow])
            csrfPage (usersPage users)

        post "/user" $ do
            Registration username password isAdmin <- validateAndDecodeJsonData
            matching_users <- liftIO (query conn "select 1 from users where username = ?" (Only username) :: IO [Only Int])
            if null matching_users then do
                userId <- liftIO $ do
                    let bytestringPassword = encodeUtf8 (password)
                    Just passwordHash <- hashPasswordUsingPolicy hashPolicy bytestringPassword
                    userId <- getRandomUserId
                    execute conn "insert into users values (?, ?, ?, ?)"
                                 (userId, username, decodeUtf8 passwordHash, isAdmin)
                    pure userId
                text (LazyText.fromStrict userId)
            else do
                text "User with that username already exists"
                status conflict409

        delete "/user" $ do
            DeleteUser userId <- validateAndDecodeJsonData :: ActionM DeleteUser
            nothingDeleted <- liftIO $ do
                execute conn "delete from users where id = ?" (Only userId)
                (== 0) <$> changes conn
            if nothingDeleted then status notFound404 else pure ()

        get "/login" $ do
            user <- authenticatedUser conn
            failed <- isJust <$> getCookie "login-failed"
            deleteCookie "login-failed"
            noCache
            case user of
                Just _ -> redirect "/"
                Nothing -> csrfPage (loginPage failed)

        post "/login" $ do
            validateCsrfTokenForm
            username <- param "username" `rescue` (const $ do status badRequest400; finish)
            passwordAttempt <- param "password" `rescue` (const $ do status badRequest400; finish)
            results <- liftIO (query conn "select id, password from users where username = ?" (Only (username :: T.Text)) :: IO [(T.Text, T.Text)])
            case results of
                (userId, passwordHash):_ | validatePassword (encodeUtf8 passwordHash) (encodeUtf8 passwordAttempt) -> do
                    identifier <- liftIO getRandomToken
                    liftIO $ execute conn "insert into logins values (?, ?)" (identifier, userId)
                    setSimpleCookie loginTokenCookie identifier
                    redirect "/"
                _ -> do
                    setSimpleCookie "login-failed" ""
                    redirect "/login"

        post "/logout" $ do
            maybeLoginToken <- getCookie loginTokenCookie
            case maybeLoginToken of
                Just loginToken -> do
                    deleteCookie loginTokenCookie
                    liftIO (execute conn "delete from logins where identifier = ?" (Only loginToken))
                Nothing -> pure ()
            redirect "/login"

        get "/" $ do
            userRow@(UserRow userId username _) <- requireAuthenticatedUser conn
            documents <- liftIO (query conn "select d.filename, d.title, d.public \
                                            \from documents d, roles \
                                            \where d.filename = roles.document \
                                            \  and roles.user_id = ? \
                                            \order by d.created_at desc" (Only userId) :: IO [Document])
            noCache
            csrfPage (dashboardPage userRow documents)

        get "/document/:filename" $ do
            filename <- param "filename" :: ActionM T.Text
            documents <- liftIO $ query conn "select filename, title, public from documents where filename = ?" (Only filename) :: ActionM [Document]
            document@(Document filename title public) <- case documents of
                                                             document:_ -> pure document
                                                             [] -> redirect "/"
            maybeUser <- authenticatedUser conn
            maybeRole <- case maybeUser of
                             Just (UserRow userId _ _) -> do
                                 maybeRole <- getUserRole conn filename userId
                                 pure $ case maybeRole of
                                     Just role -> Just role
                                     Nothing -> if public then Just Viewer else Nothing
                             Nothing -> pure $ if public then Just Viewer else Nothing
            case maybeRole of
                Just role -> do
                    body <- liftIO $ withFile (T.unpack (configFilesDirectoryPath <> "/" <> filename <> ".txt")) ReadWriteMode TIO.hGetContents
                    csrfPage (documentPage document body role)
                Nothing -> redirect "/"

        get "/share/:filename" $ do
            filename <- param "filename" :: ActionM T.Text
            UserRow userId _ _ <- requireAuthenticatedUser conn
            roles <- liftIO $ query conn "select roles.user_id, users.username, roles.type \
                                         \from roles, users \
                                         \where document = ? \
                                         \  and users.id = roles.user_id" (Only filename)
            if any (\(dbUserId, _, roleType) -> dbUserId == userId && roleType == Owner) roles then do
                -- The document is guaranteed to exist since there was at least one role associated with it.
                [document] <- liftIO $ query conn "select filename, title, public from documents where filename = ?" (Only filename)
                csrfPage (sharePage roles document)
            else redirect "/"

        post "/share/:filename" $ do
            filename <- param "filename" :: ActionM T.Text
            UserRow currentUserId _ _ <- requireAuthenticatedUser conn
            AddRole roleUsername roleType <- validateAndDecodeJsonData :: ActionM AddRole
            isOwner <- liftIO $ isDocumentOwner filename currentUserId conn
            if isOwner then do
                userIds <- liftIO $ query conn "select id from users where username = ?" (Only roleUsername)
                case userIds of
                    Only roleUserId:_ -> do
                        liftIO $ execute conn "insert into roles values (?, ?, ?)" (roleUserId, filename, roleType)
                        text roleUserId
                    [] -> status notFound404
            else status unauthorized401

        put "/share/:filename" $ do
            filename <- param "filename" :: ActionM T.Text
            UserRow currentUserId _ _ <- requireAuthenticatedUser conn
            PutRole roleUserId roleType <- validateAndDecodeJsonData :: ActionM PutRole
            isOwner <- liftIO $ isDocumentOwner filename currentUserId conn
            if isOwner then liftIO $ execute conn "update roles set type = ? where document = ? and user_id = ?"(roleType, filename, roleUserId)
            else status unauthorized401

        delete "/share/:filename" $ do
            filename <- param "filename" :: ActionM T.Text
            UserRow currentUserId _ _ <- requireAuthenticatedUser conn
            DeleteRole roleUserId <- validateAndDecodeJsonData :: ActionM DeleteRole
            isOwner <- liftIO $ isDocumentOwner filename currentUserId conn
            if isOwner then do
                nothingDeleted <- liftIO $ do
                    execute conn "delete from roles where document = ? and user_id = ?" (filename, roleUserId)
                    (== 0) <$> changes conn
                if nothingDeleted then status notFound404 else pure ()
            else status unauthorized401

        post "/document" $ do
            UserRow userId _  _ <- requireAuthenticatedUser conn
            validateAndDecodeJsonData :: ActionM Value
            filename <- liftIO $ do
                -- TODO: don't assume that the randomly generated filename has never been created before.
                filename <- encodeHex <$> getRandomBytes 20
                created_at <- round <$> getPOSIXTime :: IO Int
                execute conn "insert into documents values (?, ?, ?, ?)" (filename, "" :: T.Text, False, created_at)
                execute conn "insert into roles values (?, ?, ?)" (userId, filename, 0 :: Int)
                pure filename
            text (LazyText.fromStrict filename)

        put "/document/:filename" $ do
            UserRow userId _ _ <- requireAuthenticatedUser conn
            filename <- param "filename"
            UpdateDocument newTitle newBody newPublicity <- validateAndDecodeJsonData
            maybeRole <- getUserRole conn filename userId
            let isAuthorized = maybeRole & any (\case Editor -> isNothing newPublicity
                                                      Owner -> True
                                                      Viewer -> False)
            if isAuthorized then pure () else do status unauthorized401; finish
            liftIO $ do
                case newTitle of
                    Just title -> execute conn "update documents set title = ? \
                                               \where filename = ?" (title, filename)
                    Nothing -> pure ()
                case newBody of
                    Just body -> liftIO $ do
                        createDirectoryIfMissing False (T.unpack configFilesDirectoryPath)
                        handle <- openFile (T.unpack (configFilesDirectoryPath <> "/" <> filename <> ".txt")) WriteMode
                        TIO.hPutStr handle body
                        hFlush handle
                        hClose handle
                    Nothing -> pure ()
                case newPublicity of
                    Just public -> execute conn "update documents set public = ? \
                                                \where filename = ?" (public, filename)
                    Nothing -> pure ()

        delete "/document/:filename" $ do
            UserRow userId _ _ <- requireAuthenticatedUser conn
            filename <- param "filename"
            role <- getUserRole conn filename userId
            if any (== Owner) role then pure () else do status unauthorized401; finish
            liftIO $ execute conn "delete from documents where filename = ?" (Only filename)

    close conn