Quickstrom

elm/.gitignore

@@ -1,2 +1,3 @@
 elm-stuff
+spec/report
 index.html

elm/README.md

@@ -1,6 +1,6 @@
 # Tagger Elm client
 
-This folder contains a client application built with [Elm](https://elm-lang.org/), which allows to interact in a human-friendly way with the Tagger api.
+This folder contains a client application built with [Elm](https://elm-lang.org/), which allows interacting in a human-friendly way with the Tagger API.
 
 ## Build
 
@@ -14,9 +14,17 @@ Then, you can directly open `index.html` to interact with the application.
 
 ## Workflow
 
-The application requires you to first register a new user. Once this is done, you can login with the same credentials and access the private area.
+The application requires you to first register a new user. Once this is done, you can log in with the same credentials and access the private area.
 
-In the private area, you'll see the contents for the logged in user and you can also:
+In the private area, you'll see the contents for the logged-in user, and you can also:
 
 - add new contents with their tags;
 - filter the shown contents by tag.
+
+## Specification
+
+The `spec` folder contains some end-to-end acceptance tests written using [Quickstrom](https://quickstrom.io/).
+
+To run them, just execute `docker-compose up` from the `elm/spec` folder, given your application is exposed on `localhost:8000`.
+
+Then in the `elm/spec/report` folder you'll find an `index.html` file containing a report of each test which was executed.

elm/elm.json

@@ -12,7 +12,8 @@
             "elm/http": "2.0.0",
             "elm/json": "1.1.3",
             "elm/url": "1.0.0",
-            "mdgriffith/elm-ui": "1.1.8"
+            "mdgriffith/elm-ui": "1.1.8",
+            "stoeffel/set-extra": "1.2.3"
         },
         "indirect": {
             "elm/bytes": "1.0.8",

elm/spec/Tagger.spec.purs

@@ -0,0 +1,179 @@
+module Tagger where
+
+import Data.Array as Array
+import Data.Maybe
+import Data.String.CodeUnits as String
+import Data.Symbol
+
+import Quickstrom
+
+-- STARTING POINT
+
+readyWhen :: Selector
+readyWhen = "#title"
+
+-- ACTIONS
+
+register :: String -> String -> ProbabilisticAction
+register username password =
+               focus "#anonymous #register input.username"
+  `followedBy` enterText username
+  `followedBy` focus "#anonymous #register input.password"
+  `followedBy` enterText password
+  `followedBy` click "#anonymous #register div.button"
+
+login :: String -> String -> ProbabilisticAction
+login username password =
+               focus "#anonymous #login input.username"
+  `followedBy` enterText username
+  `followedBy` focus "#anonymous #login input.password"
+  `followedBy` enterText password
+  `followedBy` click "#anonymous #login div.button"
+
+filterByTag :: String -> ProbabilisticAction
+filterByTag tag =
+               focus "#logged #filter-by-tag input"
+  `followedBy` enterText tag
+  `followedBy` click "#logged #filter-by-tag .button"
+
+removeTag :: ProbabilisticAction
+removeTag = click "#logged .removable .tag .remove"
+
+addNewTag :: String -> ProbabilisticAction
+addNewTag tag =
+               focus "#logged #new-tag input"
+  `followedBy` enterText tag
+  `followedBy` click "#logged #new-tag .button"
+
+addNewContent :: String -> ProbabilisticAction
+addNewContent content =
+               focus "#logged input#new-content"
+  `followedBy` enterText content
+
+submitContent :: ProbabilisticAction
+submitContent = click "#logged #add-content > .button"
+
+actions :: Actions
+actions =
+  [ register "username" "password"
+  , register "otheruser" "otherpassword"
+  , login "username" "password"
+  , login "username" "wrongpassword"
+  , login "nonexistinguser" "password"
+  , filterByTag "tag1"
+  , filterByTag "tag2"
+  , filterByTag "tag3"
+  , removeTag
+  , addNewTag "tag1"
+  , addNewTag "tag2"
+  , addNewTag "tag3"
+  , addNewContent "content1"
+  , addNewContent "content2"
+  , addNewContent "content3"
+  , submitContent
+  ]
+
+-- MODEL
+
+type Tag = String
+
+type Content = {content :: String, tags :: Array Tag}
+
+-- QUERIES
+
+contentRow :: Attribute "content-row"
+contentRow = attribute (SProxy :: SProxy "content-row")
+
+extractTags :: String -> Array Tag
+extractTags i = map _.textContent (queryAll ("#logged #contents-table [tag-row=\" <> i <> \"]") {textContent})
+
+extractContents :: Array Content
+extractContents = map
+  (\r -> {content : r.textContent, tags : extractTags (fromMaybe "" r.contentRow)})
+  (queryAll "#logged #contents-table [content-row]" {textContent, contentRow})
+
+extractFilters :: Array Tag
+extractFilters = map _.textContent (queryAll "#logged #contents #filter-by-tag .tag" {textContent})
+
+extractNewContent :: Maybe String
+extractNewContent = map _.value (queryOne "#logged #add-content #new-content" {value})
+
+extractNewTags :: Array Tag
+extractNewTags = map _.textContent (queryAll "#logged #add-content #new-tag .tag" {textContent})
+
+-- STATES
+
+anonymous :: Maybe Unit
+anonymous = map (const unit) (queryOne "#anonymous" {})
+
+logged :: Maybe {filters :: Array Tag, contents :: Array Content, newContent :: String, newTags :: Array Tag}
+logged = queryOne "#logged" {} *> (
+      (\filters contents newContent newTags -> {filters : filters, contents : contents, newContent : newContent, newTags : newTags})
+  <$> Just extractFilters
+  <*> Just extractContents
+  <*> extractNewContent
+  <*> Just extractNewTags)
+
+-- ASSERTIONS
+
+titleIsTagger :: Boolean
+titleIsTagger = always (title == Just "Tagger")
+  where
+    title = map _.textContent (queryOne "#title" {textContent})
+
+isAnonymous :: Boolean
+isAnonymous = isJust anonymous
+
+isLogged :: Boolean
+isLogged = isJust logged
+
+-- TRANSITIONS
+
+remainAmonymous :: Boolean
+remainAmonymous = isAnonymous && next isAnonymous
+
+logIn :: Boolean
+logIn = isAnonymous && next isLogged
+
+addFilter :: Boolean
+addFilter
+  =  Array.length extractFilters <= next (Array.length extractFilters)
+  && Array.length extractContents >= next (Array.length extractContents)
+  && unchanged extractNewContent
+  && unchanged extractNewTags
+
+fillNewContent :: Boolean
+fillNewContent
+  =  map String.length extractNewContent < next (map String.length extractNewContent)
+  && unchanged extractFilters
+  && unchanged extractContents
+  && unchanged extractNewTags
+
+addNewContentTag :: Boolean
+addNewContentTag
+  =  Array.length extractNewTags <= next (Array.length extractNewTags)
+  && unchanged extractFilters
+  && unchanged extractContents
+  && unchanged extractNewContent
+
+submitNewContent :: Boolean
+submitNewContent
+  =  next extractNewContent == Just ""
+  && next extractNewTags == []
+  && ((next (Array.length extractContents) == Array.length extractContents + 1) || unchanged (Array.length extractContents))
+  && unchanged extractFilters
+
+-- INVARIANTS
+
+proposition :: Boolean
+proposition
+  =  titleIsTagger
+  && isAnonymous
+  && always
+    (  remainAmonymous
+    || logIn
+    || addFilter
+    || fillNewContent
+    || addNewContentTag
+    || submitNewContent
+    )

elm/spec/docker-compose.yml

@@ -0,0 +1,27 @@
+version: '3'
+
+services:
+  webdriver:
+    image: selenium/standalone-chrome:3.141.59-20200826
+    container_name: webdriver
+    volumes:
+      - /dev/shm:/dev/shm
+      - .:/spec
+    healthcheck:
+      test: curl -f http://localhost:4444 || exit 1
+      interval: 1s
+      timeout: 1s
+      retries: 5
+      start_period: 10s
+    network_mode: "host"
+
+  quickstrom:
+    image: quickstrom/quickstrom
+    container_name: quickstrom
+    volumes:
+      - .:/spec
+    command: quickstrom check --webdriver-host=webdriver --webdriver-path=/wd/hub --browser=chrome --reporter=html --html-report-directory=/spec/report --tests=10 --max-actions=50 --max-trailing-state-changes=1 --trailing-state-change-timeout=500 /spec/Tagger.spec.purs http://localhost:8000
+    depends_on:
+      webdriver:
+        condition: service_healthy
+    network_mode: "host"

elm/src/Anonymous.elm

@@ -40,11 +40,11 @@ type Msg
   | Register (SubmitMessage UserId)
   | Login (SubmitMessage Token)
 
-updateModelWithRegisterSubmit : Model -> Submit UserId -> Model
-updateModelWithRegisterSubmit model registerSubmit = { model | registerSubmit = registerSubmit }
+updateModelWithRegisterSubmit : Model -> { model : Credentials.Model, submitState : Submit UserId } -> Model
+updateModelWithRegisterSubmit model data = { model | registerSubmit = data.submitState, register = data.model }
 
-updateModelWithLoginSubmit : Model -> Submit Token -> Model
-updateModelWithLoginSubmit model loginSubmit = { model | loginSubmit = loginSubmit}
+updateModelWithLoginSubmit : Model -> { model : Credentials.Model, submitState : Submit Token } -> Model
+updateModelWithLoginSubmit model data = { model | loginSubmit = data.submitState, login = data.model }
 
 update : Msg -> Model -> ( Model, Cmd Msg )
 update msg model =
@@ -64,8 +64,9 @@ update msg model =
 
 view : Model -> Element Msg
 view model = Component.mainRow
-  [ Credentials.view "Register User" RegisterData Register model.register
-  , Credentials.view "Login" LoginData Login model.login
+  "anonymous"
+  [ Credentials.view "register" "Register User" RegisterData Register model.register
+  , Credentials.view "login"    "Login"         LoginData    Login    model.login
   ]
 
 -- HTTP

elm/src/Component.elm

@@ -2,22 +2,30 @@ module Component exposing (..)
 
 import Style exposing (..)
 
+-- elm/html
+import Html.Attributes exposing (class, id)
+
 -- mdgriffith/elm-ui
 import Element exposing (..)
 import Element.Background exposing (..)
 import Element.Border exposing (..)
 import Element.Input exposing (..)
 import Element.Font
 
-mainRow : List ( Element msg ) -> Element msg
-mainRow elements = row [ Element.width fill ] elements
+mainRow : String -> List ( Element msg ) -> Element msg
+mainRow identifier elements = row
+  [ Element.width fill
+  , htmlAttribute ( id identifier )
+  ]
+  elements
 
-mainColumn : List ( Element msg ) -> Element msg
-mainColumn elements = column
+mainColumn : String -> List ( Element msg ) -> Element msg
+mainColumn identifier elements = column
   [ normalPadding
   , bigSpacing
   , Element.width fill
   , alignTop
+  , htmlAttribute ( id identifier )
   ]
   elements
 
@@ -28,6 +36,7 @@ button : msg -> String -> Element msg
 button message label = Element.Input.button
     ( [ Element.padding 5
       , Element.focused [ Element.Background.color purple ]
+      , htmlAttribute ( class "button" )
       ] ++ buttonStyle )
     { onPress = Just message
     , label   = Element.text label

elm/src/Credentials.elm

@@ -3,6 +3,9 @@ module Credentials exposing (..)
 import Component exposing (..)
 import Style exposing (..)
 
+-- elm/html
+import Html.Attributes exposing (class)
+
 -- elm/http
 import Http exposing (..)
 
@@ -51,17 +54,18 @@ type SubmitMessage a
   | Failed Http.Error
   | Succeeded a
 
-updateSubmit : Decoder a -> String -> Model -> SubmitMessage a -> Submit a -> ( Submit a, Cmd (SubmitMessage a) )
-updateSubmit decoder url credentials submitMessage model =
+updateSubmit : Decoder a -> String -> Model -> SubmitMessage a -> Submit a -> ( { model : Model, submitState : Submit a }, Cmd (SubmitMessage a) )
+updateSubmit decoder url credentials submitMessage submitState =
   case submitMessage of
-    Submit          -> ( model, submit decoder url credentials )
-    Failed error    -> ( Failure error, Cmd.none )
-    Succeeded value -> ( Successful value, Cmd.none )
+    Submit          -> ( { model = emptyCredentials, submitState = submitState      }, submit decoder url credentials )
+    Failed error    -> ( { model = credentials     , submitState = Failure error    }, Cmd.none )
+    Succeeded value -> ( { model = credentials     , submitState = Successful value }, Cmd.none )
 
 -- VIEW
 
-view : String -> (CredentialsMessage -> msg) -> (SubmitMessage a -> msg) -> Model -> Element msg
-view title liftModel liftMessage credentials = Component.mainColumn
+view : String -> String -> (CredentialsMessage -> msg) -> (SubmitMessage a -> msg) -> Model -> Element msg
+view identifier title liftModel liftMessage credentials = Component.mainColumn
+  identifier
   [ Component.columnTitle title
   , column
     [ normalSpacing
@@ -70,13 +74,15 @@ view title liftModel liftMessage credentials = Component.mainColumn
     [ Element.map liftModel ( column
       [ normalSpacing
       ]
-      [ Element.Input.username []
+      [ Element.Input.username
+        [ htmlAttribute ( class "username" ) ]
         { onChange    = Username
         , text        = credentials.username
         , placeholder = Just ( Element.Input.placeholder [] ( Element.text "Username" ) )
         , label       = labelAbove [] ( Element.text "Username" )
         }
-      , Element.Input.newPassword []
+      , Element.Input.newPassword
+        [ htmlAttribute ( class "password" ) ]
         { onChange    = Password
         , text        = credentials.password
         , placeholder = Just ( Element.Input.placeholder [] ( Element.text "Password" ) )