{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Web.Scotty.PathNormalizer
(
addPathNormalizer
, pathNormalizerAction
, 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 []))
addPathNormalizer :: ScottyM ()
addPathNormalizer = get anyPath pathNormalizerAction
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)
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
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