@@ -0,0 +1,69 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+import Data.ByteString.Lazy.Char8 ()
3+import Data.ByteString (ByteString)
4+import Network.Wai
5+import Network.Wai.Handler.Warp (run)
6+import System.Directory (doesFileExist)
7+import System.Environment (getArgs)
8+import Data.Text (unpack)
9+import Data.Text.Encoding (decodeUtf8With)
10+import Data.Text.Encoding.Error (lenientDecode)
11+
12+main :: IO ()
13+main = do
14+ a <- getArgs
15+ let prefix =
16+ case a of
17+ [] -> id
18+ [x] -> (filter (not . null) (split x) ++)
19+ _ -> error "Usage: warp [root dir]"
20+ run 3000 $ app prefix
21+
22+app :: ([String] -> [String]) -> Application
23+app prefix Request { requestMethod = m, pathInfo = p }
24+ | m == "GET" =
25+ case checkUnsafe $ split $ unpack $ decodeUtf8With lenientDecode p of
26+ Nothing -> return $ responseLBS status403 [("Content-Type", "text/plain")] "Permission Denied"
27+ Just pieces -> do
28+ let file = join $ prefix pieces
29+ let ext = reverse $ takeWhile (/= '.') $ reverse file
30+ let ct = getCT ext
31+ e <- doesFileExist file
32+ if e
33+ then return $ ResponseFile status200 [("Content-Type", ct)] file
34+ else return $ responseLBS status404 [("Content-Type", "text/plain")] "File not found"
35+ | otherwise =
36+ return $ responseLBS status405 [("Content-Type", "text/plain")] "Bad method"
37+
38+split :: String -> [String]
39+split "" = []
40+split s =
41+ let (x, y) = break (== '/') s
42+ in x : split (drop 1 y)
43+
44+checkUnsafe :: [String] -> Maybe [String]
45+checkUnsafe [] = Nothing
46+checkUnsafe [""] = Just ["index.html"]
47+checkUnsafe [x] = Just [x]
48+checkUnsafe ("..":_) = Nothing
49+checkUnsafe (".":rest) = checkUnsafe rest
50+checkUnsafe ("":rest) = checkUnsafe rest
51+checkUnsafe (x:rest) = ((:) x) `fmap` checkUnsafe rest
52+
53+join :: [String] -> String
54+join [] = []
55+join [x] = x
56+join (x:xs) = x ++ '/' : join xs
57+
58+getCT :: String -> ByteString
59+getCT "jpg" = "image/jpeg"
60+getCT "jpeg" = "image/jpeg"
61+getCT "js" = "text/javascript"
62+getCT "css" = "text/css"
63+getCT "html" = "text/html"
64+getCT "png" = "image/png"
65+getCT "gif" = "image/gif"
66+getCT "txt" = "text/plain"
67+getCT "flv" = "video/x-flv"
68+getCT "ogv" = "video/ogg"
69+getCT _ = "application/octet-stream"