| 1 | -- | The WAI application: routing, the visitor's cookie, the origin |
| 2 | -- check, and what each route answers. |
| 3 | module Todo.App |
| 4 | ( Config (..) |
| 5 | , app |
| 6 | , version |
| 7 | , fragmentHeader |
| 8 | ) where |
| 9 | |
| 10 | import Control.Monad (join) |
| 11 | import Data.ByteString (ByteString) |
| 12 | import Data.ByteString.Lazy qualified as BL |
| 13 | import Data.Maybe (fromMaybe) |
| 14 | import Data.Text (Text) |
| 15 | import Data.Text qualified as T |
| 16 | import Data.Text.Encoding qualified as T |
| 17 | import Lucid (Html, renderBS) |
| 18 | import Network.HTTP.Types |
| 19 | import Network.Wai |
| 20 | |
| 21 | import BuildVersion (buildVersion) |
| 22 | import Todo.Assets qualified as Assets |
| 23 | import Todo.Cookie |
| 24 | import Todo.Db (Db) |
| 25 | import Todo.Db qualified as Db |
| 26 | import Todo.Form |
| 27 | import Todo.Html |
| 28 | import Todo.Model |
| 29 | |
| 30 | data Config = Config |
| 31 | { configOrigin :: Maybe ByteString |
| 32 | -- ^ This app's own origin, e.g. @https://todo-haskell.bfj.oncarlos.com@. |
| 33 | -- A POST whose @Origin@ header names any other is refused. |
| 34 | , configSecure :: Bool |
| 35 | -- ^ Served over https, so the cookie gets @Secure@. |
| 36 | } |
| 37 | |
| 38 | -- | The build, as @GET /api/version@ reports it. |
| 39 | version :: Text |
| 40 | version = T.pack buildVersion |
| 41 | |
| 42 | -- | Sent on every response. @make bump@ edits this string to force a |
| 43 | -- recompile of this module. |
| 44 | serverName :: ByteString |
| 45 | serverName = "todo-haskell" |
| 46 | |
| 47 | -- | The request header app.js sends to get 'fragment' back from an |
| 48 | -- action instead of a redirect. |
| 49 | fragmentHeader :: HeaderName |
| 50 | fragmentHeader = "X-Fragment" |
| 51 | |
| 52 | -- | Form bodies past this are refused. A 10,000-character title of |
| 53 | -- four-byte characters, percent-encoded, is about 120 KB. |
| 54 | bodyLimit :: Int |
| 55 | bodyLimit = 1024 * 1024 |
| 56 | |
| 57 | app :: Config -> Db -> Application |
| 58 | app config db req respond = case pathInfo req of |
| 59 | [] -> view All |
| 60 | ["active"] -> view Active |
| 61 | ["completed"] -> view Completed |
| 62 | ["static", "base.css"] -> get $ asset "text/css; charset=utf-8" Assets.baseCss |
| 63 | ["static", "index.css"] -> get $ asset "text/css; charset=utf-8" Assets.indexCss |
| 64 | ["static", "app.css"] -> get $ asset "text/css; charset=utf-8" Assets.appCss |
| 65 | ["static", "app.js"] -> get $ asset "text/javascript; charset=utf-8" Assets.appJs |
| 66 | ["healthz"] -> get $ respond (plain status200 "ok") |
| 67 | ["api", "version"] -> get $ respond (plain status200 (T.encodeUtf8 version)) |
| 68 | ["todos"] -> post $ \list fields -> do |
| 69 | let title = T.strip (fieldText "title" fields) |
| 70 | if T.null title then pure () else Db.addTodo db list title |
| 71 | pure True |
| 72 | ["todos", "toggle-all"] -> post $ \list _ -> True <$ Db.toggleAll db list |
| 73 | ["todos", "clear-completed"] -> post $ \list _ -> True <$ Db.clearCompleted db list |
| 74 | ["todos", raw, verb] |
| 75 | | Just todo <- parseTodoId raw -> case verb of |
| 76 | "toggle" -> post $ \list _ -> Db.toggleTodo db list todo |
| 77 | "destroy" -> post $ \list _ -> Db.deleteTodo db list todo |
| 78 | "edit" -> post $ \list fields -> do |
| 79 | let title = T.strip (fieldText "title" fields) |
| 80 | if T.null title |
| 81 | then Db.deleteTodo db list todo |
| 82 | else Db.renameTodo db list todo title |
| 83 | _ -> respond notFound |
| 84 | _ -> respond notFound |
| 85 | where |
| 86 | method = requestMethod req |
| 87 | |
| 88 | get action |
| 89 | | method == methodGet || method == methodHead = action |
| 90 | | otherwise = respond (allow "GET, HEAD") |
| 91 | |
| 92 | -- GET /, /active, /completed, optionally with ?edit=<id>. |
| 93 | view f = get $ do |
| 94 | (list, cookie) <- visitor |
| 95 | todos <- Db.listTodos db list |
| 96 | let editing = do |
| 97 | raw <- join (lookup "edit" (queryString req)) |
| 98 | todo <- parseTodoId (T.decodeUtf8Lenient raw) |
| 99 | if any (\t -> todoId t == todo && visible f t) todos then Just todo else Nothing |
| 100 | respond . withHeaders cookie $ html status200 (page (View f todos editing version)) |
| 101 | |
| 102 | -- An action: check the origin, read the form, run it against the |
| 103 | -- caller's own list. @run@ answers False when the todo it names isn't |
| 104 | -- in that list. |
| 105 | post run |
| 106 | | method /= methodPost = respond (allow "POST") |
| 107 | | not sameOrigin = respond (plain status403 "cross-origin request refused") |
| 108 | | otherwise = |
| 109 | readFields bodyLimit req >>= \case |
| 110 | Nothing -> respond (plain status413 "form too large") |
| 111 | Just fields -> do |
| 112 | (list, cookie) <- visitor |
| 113 | found <- run list fields |
| 114 | let f = parseFilter (field "filter" fields) |
| 115 | respond . withHeaders cookie =<< if |
| 116 | | not found -> pure notFound |
| 117 | | wantsFragment -> do |
| 118 | todos <- Db.listTodos db list |
| 119 | pure $ html status200 (fragment (View f todos Nothing version)) |
| 120 | | otherwise -> pure $ responseLBS status303 [(hLocation, T.encodeUtf8 (filterPath f)), common] "" |
| 121 | |
| 122 | sameOrigin = case lookup "Origin" (requestHeaders req) of |
| 123 | Nothing -> True |
| 124 | Just origin -> Just origin == configOrigin config |
| 125 | |
| 126 | wantsFragment = lookup fragmentHeader (requestHeaders req) == Just "1" |
| 127 | |
| 128 | -- The caller's list, from their cookie, or a new empty one (and the |
| 129 | -- header that hands them its cookie) if the cookie is missing or names |
| 130 | -- nothing this app holds. |
| 131 | visitor = do |
| 132 | known <- maybe (pure Nothing) (Db.findList db) (readToken (lookup hCookie (requestHeaders req))) |
| 133 | case known of |
| 134 | Just list -> pure (list, []) |
| 135 | Nothing -> do |
| 136 | token <- newToken |
| 137 | list <- Db.createList db token |
| 138 | pure (list, [(hSetCookie, setCookie (configSecure config) token)]) |
| 139 | |
| 140 | asset contentType body = |
| 141 | respond $ |
| 142 | responseLBS |
| 143 | status200 |
| 144 | [ (hContentType, contentType) |
| 145 | , (hContentLength, bytes (BL.fromStrict body)) |
| 146 | , (hCacheControl, "public, max-age=86400") |
| 147 | , common |
| 148 | ] |
| 149 | (BL.fromStrict body) |
| 150 | |
| 151 | fieldText :: Text -> Fields -> Text |
| 152 | fieldText name = fromMaybe "" . field name |
| 153 | |
| 154 | html :: Status -> Html () -> Response |
| 155 | html status doc = |
| 156 | responseLBS |
| 157 | status |
| 158 | [ (hContentType, "text/html; charset=utf-8") |
| 159 | , (hContentLength, bytes body) |
| 160 | , (hCacheControl, "no-store") |
| 161 | , ("Content-Security-Policy", csp) |
| 162 | , ("X-Content-Type-Options", "nosniff") |
| 163 | , ("Referrer-Policy", "same-origin") |
| 164 | , common |
| 165 | ] |
| 166 | body |
| 167 | where |
| 168 | body = renderBS doc |
| 169 | |
| 170 | plain :: Status -> ByteString -> Response |
| 171 | plain status body = |
| 172 | responseLBS |
| 173 | status |
| 174 | [ (hContentType, "text/plain; charset=utf-8") |
| 175 | , (hContentLength, bytes (BL.fromStrict body)) |
| 176 | , (hCacheControl, "no-store") |
| 177 | , common |
| 178 | ] |
| 179 | (BL.fromStrict body) |
| 180 | |
| 181 | notFound :: Response |
| 182 | notFound = plain status404 "not found" |
| 183 | |
| 184 | allow :: ByteString -> Response |
| 185 | allow methods = mapResponseHeaders (("Allow", methods) :) (plain status405 "method not allowed") |
| 186 | |
| 187 | withHeaders :: ResponseHeaders -> Response -> Response |
| 188 | withHeaders extra = mapResponseHeaders (<> extra) |
| 189 | |
| 190 | common :: Header |
| 191 | common = (hServer, serverName) |
| 192 | |
| 193 | bytes :: BL.ByteString -> ByteString |
| 194 | bytes = T.encodeUtf8 . T.pack . show . BL.length |
| 195 | |
| 196 | csp :: ByteString |
| 197 | csp = |
| 198 | "default-src 'self'; script-src 'self'; style-src 'self'; img-src 'self' data:; \ |
| 199 | \form-action 'self'; frame-ancestors 'none'; base-uri 'none'" |
| 200 | |
amadan