Still working on Router arrow

[Lucu.git] / Network / HTTP / Lucu / Preprocess.hs

diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs
index ca29c9a12e531432c66fcc9deced4be509820352..17a23b2435e50527674f3d51f75fb214d3dbad6b 100644 (file)
--- a/Network/HTTP/Lucu/Preprocess.hs
+++ b/Network/HTTP/Lucu/Preprocess.hs
@@ -3,6 +3,7 @@
   , OverloadedStrings
   , RecordWildCards
   , UnicodeSyntax
+  , ViewPatterns
   #-}
 module Network.HTTP.Lucu.Preprocess
     ( AugmentedRequest(..)
@@ -11,6 +12,7 @@ module Network.HTTP.Lucu.Preprocess
     )
     where
 import Control.Applicative
+import Control.Applicative.Unicode
 import Control.Monad
 import Control.Monad.State.Strict
 import Data.Ascii (Ascii)
@@ -46,8 +48,8 @@ data RequestBodyLength
     | Chunked
     deriving (Eq, Show)
 
-preprocess ∷ CI Text → PortNumber → Request → AugmentedRequest
-preprocess localHost localPort req@(Request {..})
+preprocess ∷ CI Text → PortNumber → Bool → Request → AugmentedRequest
+preprocess localHost localPort isSSL req@(Request {..})
     = execState go initialAR
     where
       initialAR ∷ AugmentedRequest
@@ -62,6 +64,7 @@ preprocess localHost localPort req@(Request {..})
       go ∷ State AugmentedRequest ()
       go = do examineHttpVersion
               examineMethod
+              examineScheme isSSL
               examineAuthority localHost localPort
               examineHeaders
               examineBodyLength
@@ -105,6 +108,20 @@ examineMethod
            DELETE → return ()
            _      → setStatus NotImplemented
 
+examineScheme ∷ Bool → State AugmentedRequest ()
+examineScheme isSSL
+    = do req ← gets arRequest
+         when (null ∘ uriScheme $ reqURI req) $
+             let uri' = (reqURI req) {
+                          uriScheme = if isSSL then
+                                          "https:"
+                                      else
+                                          "http:"
+                        }
+                 req' = req { reqURI = uri' }
+             in
+               setRequest req'
+
 examineAuthority ∷ CI Text → PortNumber → State AugmentedRequest ()
 examineAuthority localHost localPort
     = do req ← gets arRequest
@@ -115,8 +132,9 @@ examineAuthority localHost localPort
                HttpVersion 1 0
                    → let host = localHost
                          port = case localPort of
-                                  80 → ""
-                                  n  → A.unsafeFromString $ ':':show n
+                                  n | Just n ≡ defaultPort (reqURI req)
+                                        → ""
+                                  n     → A.unsafeFromString $ ':':show n
                          req' = updateAuthority host port req
                      in
                        setRequest req'
@@ -140,6 +158,13 @@ examineAuthority localHost localPort
                -- Should never reach here...
                ver → fail ("internal error: unknown version: " ⧺ show ver)
 
+defaultPort ∷ Alternative f ⇒ URI → f PortNumber
+{-# INLINEABLE defaultPort #-}
+defaultPort (uriScheme → s)
+    | s ≡ "http:"  = pure 80
+    | s ≡ "https:" = pure 443
+    | otherwise    = (∅)
+
 parseHost ∷ Ascii → (CI Text, Ascii)
 parseHost hp
     = let (h, p) = C8.break (≡ ':') $ cs hp