1 {-# LANGUAGE OverloadedStrings #-} 2 module Controller.Web 3 ( StaticPath(..) 4 , staticPath 5 , webFile 6 ) where 7 8 import Data.ByteArray.Encoding (convertToBase, Base(Base16)) 9 import qualified Data.ByteString as BS 10 import qualified Data.ByteString.Char8 as BSC 11 import Data.Char (isAscii, isAlphaNum, toLower) 12 import qualified Data.Invertible as I 13 import Data.Maybe (isJust) 14 import qualified Data.Text as T 15 import qualified Data.Text.Encoding as TE 16 import Network.HTTP.Types (notFound404, hContentEncoding) 17 import qualified Network.Wai as Wai 18 import System.Posix.FilePath (joinPath, splitDirectories, (<.>)) 19 import qualified Web.Route.Invertible as R 20 21 import Ops 22 import Has 23 import Files 24 import Model.Format 25 import Action.Route 26 import Action.Run 27 import Action.Response 28 import Action 29 import HTTP 30 import HTTP.Request 31 import HTTP.File 32 import HTTP.Path.Parser 33 import Web 34 import Web.Types 35 import Web.Cache 36 37 newtype StaticPath = StaticPath { staticFilePath :: RawFilePath } 38 39 ok :: Char -> Bool 40 ok '.' = True 41 ok '-' = True 42 ok '_' = True 43 ok c = isAscii c && isAlphaNum c 44 45 bsLCEq :: BS.ByteString -> BS.ByteString -> Bool 46 bsLCEq t s 47 | BS.length t == BS.length s = t == BSC.map toLower s 48 | otherwise = False 49 50 staticPath :: [BS.ByteString] -> StaticPath 51 staticPath = StaticPath . joinPath . map component where 52 component c 53 | not (BS.null c) && BSC.head c /= '.' && BSC.all ok c = c 54 | otherwise = error ("staticPath: " ++ BSC.unpack c) 55 56 parseStaticPath :: [T.Text] -> Maybe StaticPath 57 parseStaticPath = fmap (StaticPath . joinPath) . mapM component where 58 component c = TE.encodeUtf8 c `useWhen` (not (T.null c) && T.head c /= '.' && T.all ok c) 59 60 pathStatic :: PathParser (Maybe StaticPath) 61 pathStatic = (parseStaticPath I.:<->: maybe [] (map TE.decodeLatin1 . splitDirectories . staticFilePath)) >$< R.manyI R.parameter 62 63 webFile :: ActionRoute (Maybe StaticPath) 64 webFile = action GET ("web" >/> pathStatic) $ \sp -> withoutAuth $ do 65 StaticPath p <- maybeAction sp 66 (wf, wfi) <- either (\e -> result =<< if null e then peeks notFoundResponse else return $ response notFound404 [] (T.pack e)) return 67 =<< focusIO (lookupWebFile p) 68 agz <- any (bsLCEq "gzip") . concatMap splitHTTP <$> peeks (lookupRequestHeaders "accept-encoding") 69 wgz <- if agz then rightJust <$> focusIO (lookupWebFile (p <.> ".gz")) else return Nothing 70 r <- serveFile (webFileAbs $ maybe wf fst wgz) (unknownFormat{ formatMimeType = webFileFormat wfi }) Nothing (convertToBase Base16 $ webFileHash wfi) 71 return $ if isJust wgz then Wai.mapResponseHeaders ((hContentEncoding, "gzip") :) r else r