scotty-path-normalizer (empty) → 0.1.0.0

raw patch · 6 files changed

+293/−0 lines, 6 filesdep +basedep +bytestringdep +doctestsetup-changed

Dependencies added: base, bytestring, doctest, scotty, text, wai

Files

README.md +44/−0
Setup.hs +2/−0
license.txt +7/−0
scotty-path-normalizer.cabal +57/−0
src/Web/Scotty/PathNormalizer.hs +174/−0
test/doctest.hs +9/−0

+ README.md view

@@ -0,0 +1,44 @@+# Scotty path normalizer++This library provides a [Scotty] action that normalizes the HTTP request target+as if it were a Unix file path. When the path normalization action detects a+path that can be simplified in one of the following ways, it issues a [redirect]+to a more canonical path.++1. Remove trailing slashes: `https://typeclasses.com/contravariance/`+   becomes `https://typeclasses.com/contravariance`+2. Remove double slashes: `https://typeclasses.com//web-servers////lesson-4`+   becomes `https://typeclasses.com/web-servers/lesson-4`+3. Remove `.` segments, because `.` represents "the current directory":+   `https://typeclasses.com/ghc/./scoped-type-variables` becomes+   `https://typeclasses.com/ghc/scoped-type-variables`+4. Remove segments of the form `xyz/..`, because `..` represents "the parent+   directory": `https://typeclasses.com/python/../javascript/monoidal-folds`+   becomes `https://typeclasses.com/javascript/monoidal-folds`++The typical way to apply this to your Scotty server is to put+`addPathNormalizer` at the top of your `ScottyM` app definition.++```haskell+import qualified Web.Scotty as Scotty+import Web.Scotty.PathNormalizer (addPathNormalizer)++main :: IO ()+main =+    Scotty.scotty 3000 $+      do+        addPathNormalizer++        Scotty.get (Scotty.capture "/:word") $+          do+            beam <- Scotty.param (Data.Text.Lazy.pack "word")+            Scotty.html $ fold+                [ Data.Text.Lazy.pack "<h1>Scotty, "+                , beam+                , Data.Text.Lazy.pack " me up!</h1>"+                ]+```++  [Scotty]: https://hackage.haskell.org/package/scotty++  [redirect]: https://developer.mozilla.org/en-US/docs/Web/HTTP/Status/302

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ license.txt view

@@ -0,0 +1,7 @@+Copyright 2018 Typeclass Consulting, LLC++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

+ scotty-path-normalizer.cabal view

@@ -0,0 +1,57 @@+name: scotty-path-normalizer+version: 0.1.0.0+category: Web+synopsis: Redirect to a normalized path++description:+    Interprets dots and slashes and issues a redirect to+    a normalized path if the request target is not already+    in normal form.++homepage:    https://github.com/typeclasses/scotty-path-normalizer+bug-reports: https://github.com/typeclasses/scotty-path-normalizer/issues++author:     Chris Martin+maintainer: Chris Martin, Julie Moronuki++copyright: 2018 Typeclass Consulting, LLC+license: MIT+license-file: license.txt++build-type: Simple+cabal-version: >= 1.10++extra-source-files:+    README.md++tested-with: GHC==8.6.1, GHC==8.4.3, GHC==8.2.2++source-repository head+  type: git+  location: https://github.com/typeclasses/scotty-path-normalizer++library+  default-language: Haskell2010+  hs-source-dirs: src++  build-depends:+      base >=4.7 && <5+    , bytestring+    , scotty+    , text+    , wai++  exposed-modules:+      Web.Scotty.PathNormalizer++test-suite doctest+  default-language: Haskell2010+  hs-source-dirs: test+  type: exitcode-stdio-1.0+  main-is: doctest.hs+  ghc-options: -threaded -rtsopts -with-rtsopts=-N++  build-depends:+      base >=4.7 && <5+    , doctest+

+ src/Web/Scotty/PathNormalizer.hs view

@@ -0,0 +1,174 @@+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE NoImplicitPrelude   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Web.Scotty.PathNormalizer+    (+    -- * Scotty action+      addPathNormalizer+    , pathNormalizerAction+    -- * Normalization implementation+    , NormalizationResult (..)+    , normalizePath+    , normalizeSegmentList+    ) where++import Control.Monad+import Data.Bool+import Data.Either+import Data.Eq+import Data.Foldable+import Data.Function+import Data.Functor+import Data.Maybe+import Data.Ord+import Network.Wai+import Numeric.Natural+import Text.Show+import Web.Scotty++import Data.ByteString (ByteString)+import Data.Text       (Text)+import Prelude         ((+), (-))++import qualified Data.Text               as T+import qualified Data.Text.Encoding      as T+import qualified Data.Text.Lazy          as LT+import qualified Data.Text.Lazy.Encoding as LT++slash, dot, up :: Text+slash = T.pack "/"+dot   = T.pack "."+up    = T.pack ".."++anyPath :: RoutePattern+anyPath = function (const (Just []))++-- | Adds a Scotty route that matches all non-normalized paths,+-- where the action redirects to the corresponding normalized path.++addPathNormalizer :: ScottyM ()+addPathNormalizer = get anyPath pathNormalizerAction++-- | A Scotty action which issues a redirect to the normalized+-- form of the request target, or aborts (with 'next') if the+-- request target is already a normal path.++pathNormalizerAction :: ActionM ()+pathNormalizerAction =+  do+    req   :: Request  <- request+    path  :: Text     <- decodeUtf8 (rawPathInfo req)+    query :: Text     <- decodeUtf8 (rawQueryString req)+    path' :: Text     <- normalize path++    redirect (LT.fromStrict (path' `T.append` query))++  where+    decodeUtf8 :: ByteString -> ActionM Text+    decodeUtf8 bs =+        case (T.decodeUtf8' bs) of+            Left _  -> next+            Right x -> return x++    normalize :: Text -> ActionM Text+    normalize path =+        case (normalizePath path) of+            Invalid       -> next+            AlreadyNormal -> next+            Normalized x  -> return x++data NormalizationResult a = Invalid | AlreadyNormal | Normalized a+    deriving (Functor, Show)++-- |+-- A path that's already in normal form:+--+-- >>> normalizePath "/one/two/three"+-- AlreadyNormal+--+-- A path that contains empty segments:+--+-- >>> normalizePath "//one/./two/three/"+-- Normalized "/one/two/three"+--+-- A path that goes "up" a directory:+--+-- >>> normalizePath "/one/two/three/../four"+-- Normalized "/one/two/four"+--+-- A path that goes up too far:+--+-- >>> normalizePath "/one/../../two/three"+-- Invalid+--+-- The root path is a normalized path:+--+-- >>> normalizePath "/"+-- AlreadyNormal+--+-- The empty string is not a valid path (because a path+-- must begin with a slash):+--+-- >>> normalizePath ""+-- Invalid++normalizePath :: Text -> NormalizationResult Text+normalizePath path+    | path == slash  =  AlreadyNormal+    | otherwise      =+        case T.stripPrefix slash path of+            Nothing           -> Invalid+            Just slashRemoved -> joinSegments <$>+                normalizeSegmentList (T.split (== '/') slashRemoved)+  where+    joinSegments :: [Text] -> Text+    joinSegments [] = slash+    joinSegments xs = foldMap (\x -> slash `T.append` x) xs++-- |+-- A path that's already in normal form:+--+-- >>> normalizeSegmentList ["one", "two", "three"]+-- AlreadyNormal+--+-- A path that contains empty segments:+--+-- >>> normalizeSegmentList ["", "one", ".", "two", "three"]+-- Normalized ["one","two","three"]+--+-- A path that goes "up" a directory:+--+-- >>> normalizeSegmentList ["one", "two", "three", "..", "four"]+-- Normalized ["one","two","four"]+--+-- A path that goes up too far:+--+-- >>> normalizeSegmentList ["one", "..", "..", "two", "three"]+-- Invalid+--+-- The empty string is a normalized path:+--+-- >>> normalizeSegmentList []+-- AlreadyNormal++normalizeSegmentList :: [Text] -> NormalizationResult [Text]+normalizeSegmentList segments =++    case (foldr step init segments) of+        State _  _ False -> AlreadyNormal+        State xs 0 _     -> Normalized xs+        _                -> Invalid++data State = State [Text] Natural Bool++init :: State+init = State [] 0 False++step :: Text -> State -> State+step x (State xs parents different)+    | x == T.empty  =  State       xs    parents       True+    | x == dot      =  State       xs    parents       True+    | x == up       =  State       xs   (parents + 1)  True+    | parents > 0   =  State       xs   (parents - 1)  True+    | otherwise     =  State  (x : xs)   parents       different

+ test/doctest.hs view

@@ -0,0 +1,9 @@+import Test.DocTest++main :: IO ()+main =+  doctest+    [ "-isrc"+    , "-XOverloadedStrings"+    , "src/Web/Scotty/PathNormalizer.hs"+    ]