1 {-# LANGUAGE OverloadedStrings #-} 2 module Databrary.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 Databrary.Ops 22 import Databrary.Has 23 import Databrary.Files 24 import Databrary.Model.Format 25 import Databrary.Action.Route 26 import Databrary.Action.Run 27 import Databrary.Action.Response 28 import Databrary.Action 29 import Databrary.HTTP 30 import Databrary.HTTP.Request 31 import Databrary.HTTP.File 32 import Databrary.HTTP.Path.Parser 33 import Databrary.Web 34 import Databrary.Web.Types 35 import Databrary.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