module Network.Wai.Middleware.CleanPath
( cleanPath
, cleanPathRel
, cleanPathFunc
, splitPath
) where
import Network.Wai
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as L
import Network.URI (unEscapeString)
import qualified Data.ByteString.UTF8 as BSU
cleanPathFunc :: (B.ByteString -> Either B.ByteString [String])
-> B.ByteString
-> ([String] -> Request -> IO Response)
-> Request
-> IO Response
cleanPathFunc splitter prefix app env =
case splitter $ pathInfo env of
Right pieces -> app pieces env
Left p -> return
. Response status301
[("Location", B.concat [prefix, p, suffix])]
$ ResponseLBS L.empty
where
suffix =
case B.uncons $ queryString env of
Nothing -> B.empty
Just ('?', _) -> queryString env
_ -> B.cons '?' $ queryString env
cleanPathRel :: B.ByteString -> ([String] -> Request -> IO Response)
-> Request -> IO Response
cleanPathRel = cleanPathFunc splitPath
cleanPath :: ([String] -> Request -> IO Response) -> Request -> IO Response
cleanPath = cleanPathRel B.empty
splitPath :: B.ByteString -> Either B.ByteString [String]
splitPath s =
let corrected = B.pack $ rts $ ats $ rds $ B.unpack s
in if corrected == s
then Right $ map (BSU.toString . B.pack . unEscapeString . B.unpack)
$ filter (not . B.null)
$ B.split '/' s
else Left corrected
rds :: String -> String
rds [] = []
rds [x] = [x]
rds (a:b:c)
| a == '/' && b == '/' = rds (b:c)
| otherwise = a : rds (b:c)
ats :: String -> String
ats [] = []
ats s =
if last s == '/' || dbs (reverse s)
then s
else s ++ "/"
rts :: String -> String
rts [] = []
rts s =
if last s == '/' && dbs (tail $ reverse s)
then init s
else s
dbs :: String -> Bool
dbs ('/':_) = False
dbs ('.':_) = True
dbs (_:x) = dbs x
dbs [] = False