Bring back basic http testing flow

Author: paluh

src/WebRow.purs

@@ -2,8 +2,7 @@ module WebRow
   ( module HTTP.Response
   , module HTTP.Request
   -- , module HTTP.Except
-  )
-  where
+  ) where
 
 import WebRow.HTTP.Response (ok) as HTTP.Response
 import WebRow.HTTP.Request (body, fullPath, method) as HTTP.Request

src/WebRow/I18N/Routing.purs

@@ -14,53 +14,61 @@ import Type.Row (type (+))
 import WebRow.HTTP (HTTPExcept)
 import WebRow.HTTP (redirect) as HTTP.Response
 import WebRow.I18N.ISO639.TwoLetter (Languages, languageCode, parse, toString)
-import WebRow.Routing (FullUrl(..), ROUTING, RelativeUrl(..), Routing, _routing, fromRelativeUrl)
-import WebRow.Routing (printFullRoute, printRoute) as Routing
+import WebRow.Routing (FullUrl(..), ROUTING, RelativeUrl(..), _routing, fromRelativeUrl)
+import WebRow.Routing (Routing, printFullRoute, printRoute) as Routing
+
+type Route' langs route = { language ∷ Variant langs, route ∷ route }
 
 duplex
   ∷ ∀ langs route
   . Contractable Languages langs
   ⇒ Variant langs
   → RouteDuplex' route
-  → RouteDuplex' { language ∷ Variant langs, route ∷ route }
+  → RouteDuplex' (Route' langs route)
 duplex default (RouteDuplex routePrinter routeParser) =
   RouteDuplex printer parser
   where
     RouteDuplex langPrinter langParser =
       (as (languageCode >>> toString) (parse >>> note "Invalid language code")) segment
 
-    printer { language, route: r } = if languageCode language == languageCode default
+    printer { language: l, route: r } = if languageCode l == languageCode default
       then routePrinter r
-      else langPrinter language <> routePrinter r
+      else langPrinter l <> routePrinter r
 
     parser
       = ({ language:_, route: _ } <$> langParser <*> routeParser)
       <|> ({ language: default, route: _ } <$> routeParser)
 
-type Routing' langs routes eff = Routing ({ language ∷ Variant langs, route ∷ Variant routes }) eff
+type Routing' langs routes eff = Routing.Routing (Route' langs routes) eff
 
-type ROUTING' (langs ∷ # Type) (v ∷ # Type) = ROUTING ({ language ∷ Variant langs, route ∷ Variant v })
+type ROUTING' (langs ∷ # Type) route = ROUTING (Route' langs route)
 
-printRoute ∷ ∀ langs v eff. Variant v → Run ( routing ∷ ROUTING' langs v | eff ) RelativeUrl
+printRoute ∷ ∀ eff langs route. route → Run ( routing ∷ ROUTING' langs route | eff ) RelativeUrl
 printRoute v = map RelativeUrl $ do
   routing ← askAt _routing
   pure $ D.print routing.routeDuplex { language: routing.route.language, route: v }
 
-printFullRoute ∷ ∀ eff langs v. Variant v → Run ( routing ∷ ROUTING' langs v | eff ) FullUrl
+printFullRoute ∷ ∀ eff langs route. route → Run ( routing ∷ ROUTING' langs route | eff ) FullUrl
 printFullRoute v = map FullUrl $ (<>) <$> (askAt _routing <#> _.domain) <*> (map (un RelativeUrl) $ printRoute v)
 
-translatedRoute ∷ ∀ langs v eff. Variant langs → Variant v → Run (routing ∷ ROUTING' langs v | eff ) RelativeUrl
+translatedRoute ∷ ∀ eff langs route. Variant langs → route → Run (routing ∷ ROUTING' langs route | eff ) RelativeUrl
 translatedRoute lang v = Routing.printRoute { language: lang, route: v }
 
-translatedFullRoute ∷ ∀ langs v eff. Variant langs → Variant v → Run (routing ∷ ROUTING' langs v | eff ) FullUrl
+translatedFullRoute ∷ ∀ eff langs route. Variant langs → route → Run (routing ∷ ROUTING' langs route | eff ) FullUrl
 translatedFullRoute lang v = Routing.printFullRoute { language: lang, route: v }
 
-route ∷ ∀ eff langs route. Run (Routing' langs route + eff) (Variant route)
+fullRoute ∷ ∀ eff langs route. Run (Routing' langs route + eff) (Route' langs route)
+fullRoute = _.route <$> askAt _routing
+
+route ∷ ∀ eff langs route. Run (Routing' langs route + eff) route
 route =  _.route <<< _.route <$> askAt _routing
 
+language ∷ ∀ eff langs route. Run (Routing' langs route + eff) (Variant langs)
+language = _.language <<< _.route <$> askAt _routing
+
 redirect
   ∷ ∀ a eff langs route
-  . Variant route
+  . route
   → Run
       ( HTTPExcept
       + Routing' langs route

src/WebRow/Routing.purs

@@ -41,6 +41,12 @@ import WebRow.Routing.Types (Context, Domain, FullUrl(..), RelativeUrl(..), from
 
 _routing = SProxy ∷ SProxy "routing"
 
+-- | TODO:
+-- | Do we want to use custom effect here like
+-- |
+-- | `data RoutingF = PrintRouteF ..  | PrintFullRouteF ... | RedirectF ...
+-- |
+-- | Then we can abstract over i18n and simple routes in generic applets.
 type ROUTING route = READER (Context route)
 
 type Routing route eff = (routing ∷ ROUTING route | eff)

src/WebRow/Testing/Assertions.purs

@@ -0,0 +1,11 @@
+module WebRow.Testing.Assertions where
+
+import Prelude
+
+import Run (Run, liftEffect)
+import Test.Spec.Assertions (shouldEqual) as Assertions
+import Type.Row (type (+))
+import WebRow.Contrib.Run (EffRow)
+
+shouldEqual ∷ ∀ a eff. Show a ⇒ Eq a ⇒ a → a → Run (EffRow + eff) Unit
+shouldEqual expected given = liftEffect $ Assertions.shouldEqual expected given

test/WebRow/HTTP.purs

@@ -20,6 +20,7 @@ import HTTPure (Method(..))
 import HTTPure (Method(..), Request, fullPath) as HTTPure
 import HTTPure.Headers (empty) as Headers
 import Routing.Duplex (RouteDuplex', int, parse, print, root, segment, string) as D
+import Routing.Duplex.Generic (noArgs)
 import Routing.Duplex.Generic.Variant (variant') as RouteDuplex.Variant
 import Run (Run, extract, runBaseAff, runBaseAff', runBaseEffect)
 import Run (expand, runBaseAff, runBaseAff', runBaseEffect) as Run
@@ -31,7 +32,6 @@ import Run.Streaming.Prelude (feed, head, take) as S.P
 import Run.Streaming.Prelude (fold) as S.Prelude
 import Run.Streaming.Pull (chain) as Pull
 import Test.Spec (Spec, describe, it, pending)
-import Test.Spec.Assertions (shouldEqual)
 import Type.Prelude (SProxy(..))
 import Type.Row (type (+))
 import Unsafe.Coerce (unsafeCoerce)
@@ -40,35 +40,42 @@ import WebRow.Contrib.Run (AffRow, EffRow)
 import WebRow.Crypto (Crypto, _crypto, secret)
 import WebRow.Crypto (secret) as Crypto
 import WebRow.HTTP (HTTPExcept, HTTPResponse, Request, SetHeader, Cookies, notFound)
+import WebRow.HTTP (fullPath) as HTTP
 import WebRow.HTTP.Cookies (defaultAttributes)
 import WebRow.HTTP.Cookies (defaultAttributes, lookup, set) as Cookies
 import WebRow.HTTP.Request (_request)
 import WebRow.HTTP.Response (ok)
+import WebRow.Testing.Assertions (shouldEqual)
 import WebRow.Testing.HTTP (Client, HTTPSession, _httpSession, get, get_, request)
 import WebRow.Testing.HTTP (run, run') as Testing.HTTP
+import WebRow.Testing.HTTP.Response (Response(..))
 
 spec :: Spec Unit
 spec = do
   pure unit
-  -- describe "WebRow.HTTP" do
-  --   describe "Response" do
-  --     it "SetHeader" do
-  --       let
-  --         client = do
-  --           get_ "1"
-  --           get_ "2"
+  describe "WebRow.HTTP" do
+    describe "Response" do
+      it "SetHeader" do
+        let
+          client = do
+            response ← get "1"
+            case response of
+              HTTPResponse { parts: { body }} → shouldEqual body "TET"
+              otherwise → pure unit
+            get_ "2"
 
-  --         server req = do
-  --           cs ← Crypto.secret
-  --           c ← Lazy.force <$> Cookies.lookup "test"
-  --           liftEffect $ logShow c
-  --           void $ Cookies.set "test" { value: "test", attributes: Cookies.defaultAttributes }
-  --           r ← liftEffect $ random
-  --           ok $ (req.url <> ":" <> show r)
+          server = do
+            path ← HTTP.fullPath
+            cs ← Crypto.secret
+            c ← Lazy.force <$> Cookies.lookup "test"
+            liftEffect $ logShow c
+            void $ Cookies.set "test" { value: "test", attributes: Cookies.defaultAttributes }
+            r ← liftEffect $ random
+            ok $ "TEST" -- (req.url <> ":" <> show r)
 
-  --       httpSession <- runBaseAff' $ Testing.HTTP.run' {} pure server client
-  --       logShow $ unsafeStringify httpSession
-  --       pure unit
+        httpSession <- runBaseAff' $ Testing.HTTP.run' {} noArgs pure server client
+        logShow $ unsafeStringify httpSession
+        pure unit
 
     --  pending "feature complete"
     -- describe "Features" do

test/WebRow/I18N.purs

@@ -39,12 +39,23 @@ spec = do
   describe "I18N" do
     describe "route duplex" do
       it "should print translated path" do
+        let
+          path = print duplex ({ language: ur, route: NoArguments })
+        shouldEqual "/ur" path
+
+      it "should print empty prefix for default lang" do
         let
           path = print duplex ({ language: la, route: NoArguments })
-        shouldEqual "/la" path
+        shouldEqual "/" path
 
       it "should parse translated path" do
         let
           lang = parse duplex ("/ur")
 
         shouldEqual (hush lang <#> _.language >>> languageCode) (Just (languageCode ur))
+
+      it "should parse default langauge path" do
+        let
+          lang = parse duplex ("/")
+
+        shouldEqual (hush lang <#> _.language >>> languageCode) (Just (languageCode la))