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