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