| 1 | -- | Drives the WAI application in-process, against a fresh in-memory |
| 2 | -- database for each test. |
| 3 | module Main (main) where |
| 4 | |
| 5 | import Control.Exception (bracket) |
| 6 | import Control.Monad.IO.Class (liftIO) |
| 7 | import Data.ByteString (ByteString) |
| 8 | import Data.ByteString qualified as BS |
| 9 | import Data.ByteString.Lazy qualified as BL |
| 10 | import Data.Text qualified as T |
| 11 | import Data.Text.Encoding qualified as T |
| 12 | import Network.HTTP.Types |
| 13 | import Network.Wai (Application, requestHeaders, requestMethod) |
| 14 | import Network.Wai.Test |
| 15 | import Test.Hspec |
| 16 | |
| 17 | import Todo.App |
| 18 | import Todo.Db qualified as Db |
| 19 | |
| 20 | origin :: ByteString |
| 21 | origin = "http://127.0.0.1:8080" |
| 22 | |
| 23 | withApp :: (Application -> IO a) -> IO a |
| 24 | withApp run = bracket (Db.open ":memory:") Db.close $ \db -> |
| 25 | run (app (Config (Just origin) False) db) |
| 26 | |
| 27 | get :: ByteString -> Session SResponse |
| 28 | get path = request (setPath defaultRequest path) |
| 29 | |
| 30 | post :: ByteString -> [(ByteString, ByteString)] -> [Header] -> Session SResponse |
| 31 | post path form headers = |
| 32 | srequest $ |
| 33 | SRequest |
| 34 | (setPath defaultRequest {requestMethod = methodPost, requestHeaders = (hContentType, "application/x-www-form-urlencoded") : headers} path) |
| 35 | (BL.fromStrict (BS.drop 1 (renderSimpleQuery True form))) |
| 36 | |
| 37 | body :: SResponse -> T.Text |
| 38 | body = T.decodeUtf8 . BL.toStrict . simpleBody |
| 39 | |
| 40 | -- | Labels on the page, in order. |
| 41 | labels :: SResponse -> [T.Text] |
| 42 | labels r = |
| 43 | [ T.takeWhile (/= '<') (T.drop 1 (T.dropWhile (/= '>') chunk)) |
| 44 | | chunk <- drop 1 (T.splitOn "data-action=\"edit\"" (body r)) |
| 45 | ] |
| 46 | |
| 47 | main :: IO () |
| 48 | main = hspec $ around withApp $ do |
| 49 | describe "pages" $ do |
| 50 | it "serves an empty list and hands out a cookie" $ runSession $ do |
| 51 | r <- get "/" |
| 52 | assertStatus 200 r |
| 53 | let cookie = lookup hSetCookie (simpleHeaders r) |
| 54 | liftIO $ do |
| 55 | cookie `shouldSatisfy` maybe False ("todo_list=" `BS.isPrefixOf`) |
| 56 | cookie `shouldSatisfy` maybe False ("HttpOnly" `BS.isInfixOf`) |
| 57 | cookie `shouldSatisfy` maybe False ("SameSite=Lax" `BS.isInfixOf`) |
| 58 | cookie `shouldSatisfy` maybe False ("Path=/" `BS.isInfixOf`) |
| 59 | assertBodyContains "<section class=\"main\" hidden=\"\">" r |
| 60 | assertBodyContains "· Haskell" r |
| 61 | |
| 62 | it "keeps the cookie it handed out" $ runSession $ do |
| 63 | _ <- get "/" |
| 64 | r <- get "/" |
| 65 | assertNoHeader hSetCookie r |
| 66 | |
| 67 | it "answers health and version checks" $ runSession $ do |
| 68 | get "/healthz" >>= assertStatus 200 |
| 69 | r <- get "/api/version" |
| 70 | assertStatus 200 r |
| 71 | assertBody (BL.fromStrict (T.encodeUtf8 version)) r |
| 72 | |
| 73 | it "serves the shared stylesheets byte for byte" $ runSession $ do |
| 74 | r <- get "/static/index.css" |
| 75 | want <- liftIO (BS.readFile "../../shared/index.css") |
| 76 | assertBody (BL.fromStrict want) r |
| 77 | |
| 78 | it "says 404 for anything else" $ runSession $ |
| 79 | get "/nope" >>= assertStatus 404 |
| 80 | |
| 81 | describe "actions" $ do |
| 82 | it "adds a trimmed todo and redirects to the filter" $ runSession $ do |
| 83 | r <- post "/todos" [("title", " buy milk "), ("filter", "active")] [] |
| 84 | assertStatus 303 r |
| 85 | assertHeader hLocation "/active" r |
| 86 | page <- get "/" |
| 87 | liftIO $ labels page `shouldBe` ["buy milk"] |
| 88 | |
| 89 | it "ignores a blank title" $ runSession $ do |
| 90 | _ <- post "/todos" [("title", " ")] [] |
| 91 | page <- get "/" |
| 92 | liftIO $ labels page `shouldBe` [] |
| 93 | |
| 94 | it "sends an unknown filter back to /" $ runSession $ do |
| 95 | r <- post "/todos" [("title", "x"), ("filter", "bogus")] [] |
| 96 | assertHeader hLocation "/" r |
| 97 | |
| 98 | it "toggles, renames and deletes" $ runSession $ do |
| 99 | mapM_ (\t -> post "/todos" [("title", t)] []) ["a", "b", "c"] |
| 100 | post "/todos/1/toggle" [("filter", "all")] [] >>= assertStatus 303 |
| 101 | active <- get "/active" |
| 102 | liftIO $ labels active `shouldBe` ["b", "c"] |
| 103 | completed <- get "/completed" |
| 104 | liftIO $ labels completed `shouldBe` ["a"] |
| 105 | _ <- post "/todos/2/edit" [("title", " bee ")] [] |
| 106 | _ <- post "/todos/3/edit" [("title", " ")] [] |
| 107 | page <- get "/" |
| 108 | liftIO $ labels page `shouldBe` ["a", "bee"] |
| 109 | _ <- post "/todos/1/destroy" [] [] |
| 110 | page' <- get "/" |
| 111 | liftIO $ labels page' `shouldBe` ["bee"] |
| 112 | |
| 113 | it "toggles all, and back when all were done" $ runSession $ do |
| 114 | mapM_ (\t -> post "/todos" [("title", t)] []) ["a", "b"] |
| 115 | _ <- post "/todos/1/toggle" [] [] |
| 116 | _ <- post "/todos/toggle-all" [] [] |
| 117 | done <- get "/completed" |
| 118 | liftIO $ labels done `shouldBe` ["a", "b"] |
| 119 | _ <- post "/todos/toggle-all" [] [] |
| 120 | active <- get "/active" |
| 121 | liftIO $ labels active `shouldBe` ["a", "b"] |
| 122 | |
| 123 | it "clears completed todos" $ runSession $ do |
| 124 | mapM_ (\t -> post "/todos" [("title", t)] []) ["a", "b"] |
| 125 | _ <- post "/todos/2/toggle" [] [] |
| 126 | _ <- post "/todos/clear-completed" [] [] |
| 127 | page <- get "/" |
| 128 | liftIO $ labels page `shouldBe` ["a"] |
| 129 | |
| 130 | it "answers a fragment when app.js asks for one" $ runSession $ do |
| 131 | r <- post "/todos" [("title", "x")] [(fragmentHeader, "1")] |
| 132 | assertStatus 200 r |
| 133 | liftIO $ body r `shouldSatisfy` T.isPrefixOf "<section class=\"main\">" |
| 134 | |
| 135 | it "opens the editor with ?edit=" $ runSession $ do |
| 136 | _ <- post "/todos" [("title", "x")] [] |
| 137 | r <- get "/?edit=1" |
| 138 | assertBodyContains "<li data-id=\"1\" class=\"editing\">" r |
| 139 | assertBodyContains "action=\"/todos/1/edit\"" r |
| 140 | |
| 141 | describe "safety" $ do |
| 142 | it "refuses a cross-origin post and accepts its own origin" $ runSession $ do |
| 143 | post "/todos" [("title", "evil")] [("Origin", "https://evil.example")] >>= assertStatus 403 |
| 144 | post "/todos" [("title", "fine")] [("Origin", origin)] >>= assertStatus 303 |
| 145 | page <- get "/" |
| 146 | liftIO $ labels page `shouldBe` ["fine"] |
| 147 | |
| 148 | it "keeps lists apart" $ \application -> do |
| 149 | runSession (post "/todos" [("title", "mine")] [] >> pure ()) application |
| 150 | runSession |
| 151 | ( do |
| 152 | post "/todos/1/toggle" [] [] >>= assertStatus 404 |
| 153 | post "/todos/1/edit" [("title", "stolen")] [] >>= assertStatus 404 |
| 154 | post "/todos/1/destroy" [] [] >>= assertStatus 404 |
| 155 | page <- get "/" |
| 156 | liftIO $ labels page `shouldBe` [] |
| 157 | ) |
| 158 | application |
| 159 | |
| 160 | it "gives a garbled cookie a fresh list" $ runSession $ do |
| 161 | r <- request (setPath defaultRequest {requestHeaders = [(hCookie, "todo_list=%%%")]} "/") |
| 162 | assertStatus 200 r |
| 163 | assertHeaderContains' hSetCookie "todo_list=" r |
| 164 | |
| 165 | it "escapes titles and keeps Unicode" $ runSession $ do |
| 166 | _ <- post "/todos" [("title", T.encodeUtf8 "<img src=x> & \"q\" naïve 🚀")] [] |
| 167 | r <- get "/" |
| 168 | assertBodyContains (BL.fromStrict (T.encodeUtf8 "<img src=x> & "q" naïve 🚀")) r |
| 169 | assertHeader hContentLength (T.encodeUtf8 (T.pack (show (BL.length (simpleBody r))))) r |
| 170 | |
| 171 | it "takes a 10,000 character title" $ runSession $ do |
| 172 | let long = T.replicate 10000 "日" |
| 173 | post "/todos" [("title", T.encodeUtf8 long)] [] >>= assertStatus 303 |
| 174 | r <- get "/" |
| 175 | liftIO $ labels r `shouldBe` [long] |
| 176 | where |
| 177 | assertHeaderContains' name needle r = |
| 178 | liftIO $ lookup name (simpleHeaders r) `shouldSatisfy` maybe False (needle `BS.isPrefixOf`) |
| 179 | |
amadan