0b13b4f · typeable/wai

78import qualified Data.Text.Encoding.Error as TEE

79

80import Control.Arrow ((&&&), second)

81−import Data.List (groupBy, sortBy)

81+import Data.List (groupBy, sortBy, find)

82import Data.Function (on)

83import Data.Ord (comparing)

84import qualified Data.ByteString.Base64 as B64

89debug :: (Show a) => a -> a

90debug a = trace ("DEBUG: " ++ show a) a

91#else

92−trace :: String -> a -> a

93−trace _ x = x

94debug :: a -> a

92debug :: a -> a

95debug = id

93debug = id

96#endif

94#endif

235pathFromPieces prefix pieces =

233pathFromPieces prefix pieces =

236 concat $ prefix : map ((:) '/') (map pieceRaw pieces)

234 concat $ prefix : map ((:) '/') (map pieceRaw pieces)

237

235

236+checkSpecialDirListing :: Pieces -> Maybe CheckPieces

237+checkSpecialDirListing [Piece _ ".hidden", Piece _ "folder.png"] =

238+ Just $ SendContent "image/png" $ L.fromChunks [$(embedFile "folder.png")]

239+checkSpecialDirListing [Piece _ ".hidden", Piece _ "haskell.png"] =

240+ Just $ SendContent "image/png" $ L.fromChunks [$(embedFile "haskell.png")]

241+checkSpecialDirListing _ = Nothing

242+

238checkPieces :: (Pieces -> IO FileLookup) -- ^ file lookup function

243checkPieces :: (Pieces -> IO FileLookup) -- ^ file lookup function

239 -> [T.Text] -- ^ List of default index files. Cannot contain slashes.

244 -> [T.Text] -- ^ List of default index files. Cannot contain slashes.

240 -> Pieces -- ^ parsed request

245 -> Pieces -- ^ parsed request

241 -> W.Request

246 -> W.Request

242− -> StaticSettings

247+ -> MaxAge

243 -> IO CheckPieces

248 -> IO CheckPieces

244−checkPieces _ _ [Piece _ ".hidden", Piece _ "folder.png"] _ _ =

245− return $ SendContent "image/png" $ L.fromChunks [$(embedFile "folder.png")]

246−checkPieces _ _ [Piece _ ".hidden", Piece _ "haskell.png"] _ _ =

247− return $ SendContent "image/png" $ L.fromChunks [$(embedFile "haskell.png")]

248−checkPieces fileLookup indices pieces req ss

249+checkPieces fileLookup indices pieces req maxAge

249 | any (unsafe . piecePretty) pieces = return Forbidden

250 | any (unsafe . piecePretty) pieces = return Forbidden

250 | any (T.null . piecePretty) $ safeInit pieces =

251 | any (T.null . piecePretty) $ safeInit pieces =

251 return $ Redirect $ filterButLast (not . T.null . piecePretty) pieces

252 return $ Redirect $ filterButLast (not . T.null . piecePretty) pieces

277 hash <- getHash

278 hash <- getHash

278 if hash == lastHash

279 if hash == lastHash

279 then return NotModified

280 then return NotModified

280− else return $ FileResponse file $ cc [("ETag", hash)]

281+ else return $ FileResponse file $ [("ETag", hash)] ++ cacheControl

281 _ ->

282 _ ->

282 case (lookup "if-modified-since" headers >>= parseDate, fileGetModified file) of

283 case (lookup "if-modified-since" headers >>= parseDate, fileGetModified file) of

283 (Just lastSent, Just modified) -> do

284 (Just lastSent, Just modified) -> do

290 mhash <- maybe (return Nothing) (fmap Just) $ fileGetHash file

291 mhash <- maybe (return Nothing) (fmap Just) $ fileGetHash file

291 let hash =

292 let hash =

292 case mhash of

293 case mhash of

293− Just h -> (:) ("ETag", h)

294+ Just h -> [("ETag", h)]

294− Nothing -> id

295+ Nothing -> []

295− return $ FileResponse file $ hash $ cc []

296+ return $ FileResponse file $ hash ++ cacheControl

296−

297− ccInt =

298− case ssMaxAge ss of

299− NoMaxAge -> Nothing

300− MaxAgeSeconds i -> Just i

301− MaxAgeForever -> Just oneYear

302− cc =

303− case ccInt of

304− Nothing -> id

305− Just i -> (:) ("Cache-Control", S8.append "max-age" $ S8.pack $ show i)

306

297

298+ setLast :: Pieces -> Piece -> Pieces

307 setLast [] x = [x]

299 setLast [] x = [x]

308 setLast [Piece "" ""] x = [x]

300 setLast [Piece "" ""] x = [x]

309 setLast (a:b) x = a : setLast b x

301 setLast (a:b) x = a : setLast b x

310

302

311 checkIndices :: [T.Text] -> Maybe T.Text

303 checkIndices :: [T.Text] -> Maybe T.Text

312− checkIndices contents =

304+ checkIndices contents = find (flip elem indices) contents

313− go indices

305+

306+ cacheControl = case ccInt of

307+ Nothing -> []

308+ Just i -> [("Cache-Control", S8.append "max-age" $ S8.pack $ show i)]

314 where

309 where

310+ ccInt =

311+ case maxAge of

315− go [] = Nothing

312+ NoMaxAge -> Nothing

316− go (i:is)

313+ MaxAgeSeconds i -> Just i

317− | i `elem` contents = Just i

314+ MaxAgeForever -> Just oneYear

318− | otherwise = go is

315+ oneYear :: Int

316+ oneYear = 60 * 60 * 24 * 365

319

317

320type Listing = (Pieces -> Folder -> IO L.ByteString)

318type Listing = (Pieces -> Folder -> IO L.ByteString)

321

319

322−oneYear :: Int

323−oneYear = 60 * 60 * 24 * 365

324

320

325type FileLookup = Maybe (Either Folder File)

321type FileLookup = Maybe (Either Folder File)

326

322

345 , ssMkRedirect :: Pieces -> ByteString -> ByteString

341 , ssMkRedirect :: Pieces -> ByteString -> ByteString

346 , ssGetMimeType :: File -> IO MimeType

342 , ssGetMimeType :: File -> IO MimeType

347 , ssListing :: Maybe Listing

343 , ssListing :: Maybe Listing

348− , ssIndices :: [T.Text]

344+ , ssIndices :: [T.Text] -- index.html

349 , ssMaxAge :: MaxAge

345 , ssMaxAge :: MaxAge

350 }

346 }

351

347

497 "Only GET is supported"

493 "Only GET is supported"

498staticAppPieces ss pieces req = liftIO $ do

494staticAppPieces ss pieces req = liftIO $ do

499 let indices = ssIndices ss

495 let indices = ssIndices ss

496+ case checkSpecialDirListing pieces of

497+ Just res -> response res

500− cp <- checkPieces (ssFolder ss) indices pieces req ss

498+ Nothing -> checkPieces (ssFolder ss) indices pieces req (ssMaxAge ss) >>= response

499+ where

501− case cp of

500+ response cp = case cp of

502 FileResponse file ch -> do

501 FileResponse file ch -> do

503 mimetype <- ssGetMimeType ss file

502 mimetype <- ssGetMimeType ss file

504 let filesize = fileGetSize file

503 let filesize = fileGetSize file