module Space.Server
( run
, OpenAt(..)
, parseOpenAt
) where
import Space.Import
import qualified Data.ByteString.Char8 as B
import Text.Read (readMaybe)
import Network.HTTP.Types
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import Space.UnixSocket
import Space.ModifiedTime
data OpenAt
= OpenAtPort Warp.Port
| OpenAtUnixSocket FilePath
parseOpenAt :: String -> OpenAt
parseOpenAt s = case readMaybe s :: Maybe Warp.Port of
Just p -> OpenAtPort p
Nothing -> OpenAtUnixSocket s
instance Show OpenAt where
show (OpenAtPort port) = "port " ++ show port
show (OpenAtUnixSocket path) = "Unix socket " ++ show path
run :: OpenAt -> ByteString -> Wai.Application -> IO ()
run openAt urlPrefix app = do
B.putStrLn $ mconcat ["Server is opening at ", B.pack (show openAt), ".."]
case openAt of
OpenAtPort p -> Warp.runSettings
(Warp.setPort p Warp.defaultSettings) go
OpenAtUnixSocket s -> do
sock <- unixSocket s
Warp.runSettingsSocket Warp.defaultSettings sock go
where
go req respond
| not (urlPrefix `B.isPrefixOf` url) = respond notFound
| not (isSafeURL url) = respond notFound
| (urlPrefix <> "/static/") `B.isPrefixOf` url = serveThis
| (urlPrefix <> "/asset/") `B.isPrefixOf` url = serveThis
| otherwise = app appReq respond
where
url = Wai.rawPathInfo req
appReq = req { Wai.rawPathInfo = B.drop (B.length urlPrefix) url }
serveThis = serve (B.drop (B.length urlPrefix + 1) url) req respond
serve :: ByteString -> Wai.Application
serve path req respond = case mimetype (extension path) of
Just ctype -> do
fileMTime <- getMTime path
respond $ case modifiedSince req fileMTime of
NotModified -> notModified
Modified -> Wai.responseFile status200
[ (hContentType, ctype)
, (hLastModified, formattedMTime fileMTime)
]
(B.unpack path) Nothing
Nothing -> respond notFound
notFound :: Wai.Response
notFound = Wai.responseLBS status404
[(hContentType, "text/plain")]
"Page not found"
notModified :: Wai.Response
notModified = Wai.responseLBS status304 [] ""
isSafeURL :: ByteString -> Bool
isSafeURL url = and
[ B.all urlChar url
, not $ "//" `B.isInfixOf` url
, not $ "../" `B.isInfixOf` url
, not $ ".." `B.isSuffixOf` url
]
urlChar :: Char -> Bool
urlChar c = or
[ ord 'a' <= n && n <= ord 'z'
, ord 'A' <= n && n <= ord 'Z'
, ord '0' <= n && n <= ord '9'
, c `B.elem` "-_./"
]
where
n = ord c
mimetype :: ByteString -> Maybe ByteString
mimetype ext = case ext of
"jpg" -> Just "image/jpeg"
"png" -> Just "image/png"
"svg" -> Just "image/svg+xml"
"js" -> Just "application/javascript; charset=utf-8"
"css" -> Just "text/css"
"pdf" -> Just "application/pdf"
"eot" -> Just "application/vnd.ms-fontobject"
"ttf" -> Just "application/octet-stream"
"woff" -> Just "application/font-woff"
"woff2" -> Just "application/font-woff2"
"txt" -> Just "text/plain"
"ico" -> Just "image/vnd.microsoft.icon"
_ -> Nothing
cExtensionLongest :: Int
cExtensionLongest = 5
extension :: ByteString -> ByteString
extension path = snd $ B.breakEnd (== '.') $
B.drop (B.length path cExtensionLongest) path