module Network.WAI.Application.StaticPages (
parseRoutePaths
, renderStaticPages
) where
import Data.List (partition)
import Network.Wai
import Network.Wai.Test
import Network.HTTP.Types as H
import Data.Conduit (runResourceT)
import Blaze.ByteString.Builder (toLazyByteString)
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as LBS
renderStaticPages :: [Char] -> [String] -> Application -> IO ()
renderStaticPages directory requests app = do
flip mapM_ requests $ \path -> do
let p = noFrontSlash $ noTrailSlash path
let req = setRawPathInfo defaultRequest $ BS8.pack p
let outPath = (directory ++ (BS8.unpack $ rawPathInfo req) ++ ".html")
print (p, outPath)
rsp <- runResourceT $ app req
case rsp of
ResponseBuilder s h b ->
let body = toLazyByteString b
in if s /= H.status200 then error $ "unexpected status: " ++ show s ++ "\nheaders: " ++ show h ++ "\nbody: " ++ show body else
LBS.writeFile outPath body
_ -> error "expected ResponseBuilder"
noTrailSlash :: String -> String
noTrailSlash = reverse . noFrontSlash . reverse
noFrontSlash :: String -> String
noFrontSlash ('/':str) = str
noFrontSlash str = str
parseRoutePaths :: String -> [String]
parseRoutePaths =
parse [(0, "")] . filter (not . null) . lines
where
parse :: [(Int, String)] -> [String] -> [String]
parse _ [] = []
parse prefixes (line:[]) = [snd $ parseLine prefixes line]
parse prefixes (line:nextLine:otherLines) =
let (prefixes', parsed) = parseLine prefixes line
(nextPrefixes, nextParsed) = parseLine prefixes' nextLine
rest = nextParsed : parse nextPrefixes otherLines
in if length nextPrefixes > length prefixes'
then rest
else parsed : rest
parseLine :: [(Int, String)] -> String -> ([(Int, String)], String)
parseLine prefixes line = (prefixes', parsed)
where
(smaller_prefixes, _) = partition (\(indent, _) -> numSpaces > indent) prefixes
numSpaces = length spaces
spaces = takeWhile (== ' ') line
prefixes' =
if null smaller_prefixes || numSpaces > (fst $ last smaller_prefixes)
then smaller_prefixes ++ [newPrefix]
else smaller_prefixes
newPrefix = (numSpaces, path)
parsed = foldl1 (</>) (map snd smaller_prefixes ++ [path])
where
a </> b = noTrailSlash a ++ "/" ++ noFrontSlash b
path =
case words line of
[p] -> p
_ -> error $ "Invalid line: " ++ line