module Yesod.Helpers.Static
(
Static (..)
, StaticRoute (..)
, static
, staticFiles
, base64md5
#if TEST
, testSuite
#endif
) where
import System.Directory
import Control.Monad
import Yesod.Handler
import Yesod.Core
import Data.List (intercalate)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Data.Char
import qualified Data.ByteString.Lazy as L
import Data.Digest.Pure.MD5
import qualified Data.ByteString.Base64
import qualified Data.ByteString.Char8 as S8
import qualified Data.Serialize
import Data.Text (Text, pack)
import Data.Monoid (mempty)
import Network.Wai.Application.Static
( defaultMimeTypeByExt, StaticSettings (..), staticAppPieces
, defaultListing
)
#if TEST
import Test.Framework (testGroup, Test)
import Test.Framework.Providers.HUnit
import Test.HUnit hiding (Test)
#endif
import System.IO (withBinaryFile, IOMode (ReadMode))
newtype Static = Static StaticSettings
static :: FilePath -> Static
static fp = Static $ StaticSettings fp [] (Just defaultListing)
(return . defaultMimeTypeByExt)
data StaticRoute = StaticRoute [Text] [(Text, Text)]
deriving (Eq, Show, Read)
type instance Route Static = StaticRoute
instance RenderRoute StaticRoute where
renderRoute (StaticRoute x y) = (x, y)
instance Yesod master => YesodDispatch Static master where
yesodDispatch (Static set) _ pieces _ _ =
Just $ staticAppPieces set pieces
notHidden :: FilePath -> Bool
notHidden ('.':_) = False
notHidden "tmp" = False
notHidden _ = True
getFileList :: FilePath -> IO [[String]]
getFileList = flip go id
where
go :: String -> ([String] -> [String]) -> IO [[String]]
go fp front = do
allContents <- filter notHidden `fmap` getDirectoryContents fp
let fullPath :: String -> String
fullPath f = fp ++ '/' : f
files <- filterM (doesFileExist . fullPath) allContents
let files' = map (front . return) files
dirs <- filterM (doesDirectoryExist . fullPath) allContents
dirs' <- mapM (\f -> go (fullPath f) (front . (:) f)) dirs
return $ concat $ files' : dirs'
staticFiles :: FilePath -> Q [Dec]
staticFiles fp = do
fs <- qRunIO $ getFileList fp
concat `fmap` mapM go fs
where
replace' c
| 'A' <= c && c <= 'Z' = c
| 'a' <= c && c <= 'z' = c
| '0' <= c && c <= '9' = c
| otherwise = '_'
go f = do
let adjust [] = ""
adjust str@(x:xs) | isDigit x = '_' : x : xs
| isUpper x = toLower x : xs
| otherwise = str
let name = mkName $ intercalate "_" $ map (adjust . map replace') f
f' <- [|map pack $(lift f)|]
let sr = ConE $ mkName "StaticRoute"
hash <- qRunIO . calcHash $ fp ++ '/' : intercalate "/" f
pack' <- [|pack|]
qs <- [|[(pack $(lift hash), mempty)]|]
return
[ SigD name $ ConT ''Route `AppT` ConT ''Static
, FunD name
[ Clause [] (NormalB $ sr `AppE` f' `AppE` qs) []
]
]
#if TEST
testSuite :: Test
testSuite = testGroup "Yesod.Helpers.Static"
[ testCase "get file list" caseGetFileList
]
caseGetFileList :: Assertion
caseGetFileList = do
x <- getFileList "test"
x @?= [["foo"], ["bar", "baz"]]
#endif
base64md5 :: L.ByteString -> String
base64md5 = map go
. take 8
. S8.unpack
. Data.ByteString.Base64.encode
. Data.Serialize.encode
. md5
where
go '+' = '-'
go '/' = '_'
go c = c
calcHash :: FilePath -> IO String
calcHash fname =
withBinaryFile fname ReadMode hashHandle
where
hashHandle h = do s <- L.hGetContents h
return $! base64md5 s