-- | The WAI application: routing, the visitor's cookie, the origin
-- check, and what each route answers.
module Todo.App
  ( Config (..)
  , app
  , version
  , fragmentHeader
  ) where

import Control.Monad (join)
import Data.ByteString (ByteString)
import Data.ByteString.Lazy qualified as BL
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Lucid (Html, renderBS)
import Network.HTTP.Types
import Network.Wai

import BuildVersion (buildVersion)
import Todo.Assets qualified as Assets
import Todo.Cookie
import Todo.Db (Db)
import Todo.Db qualified as Db
import Todo.Form
import Todo.Html
import Todo.Model

data Config = Config
  { configOrigin :: Maybe ByteString
  -- ^ This app's own origin, e.g. @https://todo-haskell.bfj.oncarlos.com@.
  -- A POST whose @Origin@ header names any other is refused.
  , configSecure :: Bool
  -- ^ Served over https, so the cookie gets @Secure@.
  }

-- | The build, as @GET /api/version@ reports it.
version :: Text
version = T.pack buildVersion

-- | Sent on every response. @make bump@ edits this string to force a
-- recompile of this module.
serverName :: ByteString
serverName = "todo-haskell"

-- | The request header app.js sends to get 'fragment' back from an
-- action instead of a redirect.
fragmentHeader :: HeaderName
fragmentHeader = "X-Fragment"

-- | Form bodies past this are refused. A 10,000-character title of
-- four-byte characters, percent-encoded, is about 120 KB.
bodyLimit :: Int
bodyLimit = 1024 * 1024

app :: Config -> Db -> Application
app config db req respond = case pathInfo req of
  [] -> view All
  ["active"] -> view Active
  ["completed"] -> view Completed
  ["static", "base.css"] -> get $ asset "text/css; charset=utf-8" Assets.baseCss
  ["static", "index.css"] -> get $ asset "text/css; charset=utf-8" Assets.indexCss
  ["static", "app.css"] -> get $ asset "text/css; charset=utf-8" Assets.appCss
  ["static", "app.js"] -> get $ asset "text/javascript; charset=utf-8" Assets.appJs
  ["healthz"] -> get $ respond (plain status200 "ok")
  ["api", "version"] -> get $ respond (plain status200 (T.encodeUtf8 version))
  ["todos"] -> post $ \list fields -> do
    let title = T.strip (fieldText "title" fields)
    if T.null title then pure () else Db.addTodo db list title
    pure True
  ["todos", "toggle-all"] -> post $ \list _ -> True <$ Db.toggleAll db list
  ["todos", "clear-completed"] -> post $ \list _ -> True <$ Db.clearCompleted db list
  ["todos", raw, verb]
    | Just todo <- parseTodoId raw -> case verb of
        "toggle" -> post $ \list _ -> Db.toggleTodo db list todo
        "destroy" -> post $ \list _ -> Db.deleteTodo db list todo
        "edit" -> post $ \list fields -> do
          let title = T.strip (fieldText "title" fields)
          if T.null title
            then Db.deleteTodo db list todo
            else Db.renameTodo db list todo title
        _ -> respond notFound
  _ -> respond notFound
  where
    method = requestMethod req

    get action
      | method == methodGet || method == methodHead = action
      | otherwise = respond (allow "GET, HEAD")

    -- GET /, /active, /completed, optionally with ?edit=<id>.
    view f = get $ do
      (list, cookie) <- visitor
      todos <- Db.listTodos db list
      let editing = do
            raw <- join (lookup "edit" (queryString req))
            todo <- parseTodoId (T.decodeUtf8Lenient raw)
            if any (\t -> todoId t == todo && visible f t) todos then Just todo else Nothing
      respond . withHeaders cookie $ html status200 (page (View f todos editing version))

    -- An action: check the origin, read the form, run it against the
    -- caller's own list. @run@ answers False when the todo it names isn't
    -- in that list.
    post run
      | method /= methodPost = respond (allow "POST")
      | not sameOrigin = respond (plain status403 "cross-origin request refused")
      | otherwise =
          readFields bodyLimit req >>= \case
            Nothing -> respond (plain status413 "form too large")
            Just fields -> do
              (list, cookie) <- visitor
              found <- run list fields
              let f = parseFilter (field "filter" fields)
              respond . withHeaders cookie =<< if
                | not found -> pure notFound
                | wantsFragment -> do
                    todos <- Db.listTodos db list
                    pure $ html status200 (fragment (View f todos Nothing version))
                | otherwise -> pure $ responseLBS status303 [(hLocation, T.encodeUtf8 (filterPath f)), common] ""

    sameOrigin = case lookup "Origin" (requestHeaders req) of
      Nothing -> True
      Just origin -> Just origin == configOrigin config

    wantsFragment = lookup fragmentHeader (requestHeaders req) == Just "1"

    -- The caller's list, from their cookie, or a new empty one (and the
    -- header that hands them its cookie) if the cookie is missing or names
    -- nothing this app holds.
    visitor = do
      known <- maybe (pure Nothing) (Db.findList db) (readToken (lookup hCookie (requestHeaders req)))
      case known of
        Just list -> pure (list, [])
        Nothing -> do
          token <- newToken
          list <- Db.createList db token
          pure (list, [(hSetCookie, setCookie (configSecure config) token)])

    asset contentType body =
      respond $
        responseLBS
          status200
          [ (hContentType, contentType)
          , (hContentLength, bytes (BL.fromStrict body))
          , (hCacheControl, "public, max-age=86400")
          , common
          ]
          (BL.fromStrict body)

fieldText :: Text -> Fields -> Text
fieldText name = fromMaybe "" . field name

html :: Status -> Html () -> Response
html status doc =
  responseLBS
    status
    [ (hContentType, "text/html; charset=utf-8")
    , (hContentLength, bytes body)
    , (hCacheControl, "no-store")
    , ("Content-Security-Policy", csp)
    , ("X-Content-Type-Options", "nosniff")
    , ("Referrer-Policy", "same-origin")
    , common
    ]
    body
  where
    body = renderBS doc

plain :: Status -> ByteString -> Response
plain status body =
  responseLBS
    status
    [ (hContentType, "text/plain; charset=utf-8")
    , (hContentLength, bytes (BL.fromStrict body))
    , (hCacheControl, "no-store")
    , common
    ]
    (BL.fromStrict body)

notFound :: Response
notFound = plain status404 "not found"

allow :: ByteString -> Response
allow methods = mapResponseHeaders (("Allow", methods) :) (plain status405 "method not allowed")

withHeaders :: ResponseHeaders -> Response -> Response
withHeaders extra = mapResponseHeaders (<> extra)

common :: Header
common = (hServer, serverName)

bytes :: BL.ByteString -> ByteString
bytes = T.encodeUtf8 . T.pack . show . BL.length

csp :: ByteString
csp =
  "default-src 'self'; script-src 'self'; style-src 'self'; img-src 'self' data:; \
  \form-action 'self'; frame-ancestors 'none'; base-uri 'none'"