Spock 0.1.0.0 → 0.1.1.0
raw patch · 2 files changed
+2/−209 lines, 2 files
Files
- Spock.cabal +2/−2
- Web/Spock/StaticMiddleware.hs +0/−207
Spock.cabal view
@@ -1,5 +1,5 @@ name: Spock-version: 0.1.0.0+version: 0.1.1.0 synopsis: Another Haskell web toolkit based on scotty description: This toolbox provides everything you need to get a quick start into web hacking with haskell: sessions, database helper, authentication and the power of scotty Homepage: https://github.com/agrafix/Spock@@ -13,7 +13,7 @@ cabal-version: >=1.8 library- exposed-modules: Web.Spock, Web.Spock.StaticMiddleware+ exposed-modules: Web.Spock other-modules: Web.Spock.SessionManager, Web.Spock.Monad build-depends: base >= 4 && < 5, scotty >= 0.5, wai, filepath, directory, http-types, text, containers, bytestring, mtl, wai-extra, resourcet, stm, crypto-api == 0.10.*, unordered-containers, old-locale, base64-bytestring, time, monad-control, transformers, cryptohash, xsd, aeson, resource-pool
− Web/Spock/StaticMiddleware.hs
@@ -1,207 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Serve static files, subject to a policy that can filter or--- modify incoming URIs. The flow is:------ incoming request URI ==> policies ==> exists? ==> respond------ If any of the polices fail, or the file doesn't--- exist, then the middleware gives up and calls the inner application.--- If the file is found, the middleware chooses a content type based--- on the file extension and returns the file contents as the response.--- Stolen from:--- https://github.com/xich/scotty/blob/master/Network/Wai/Middleware/Static.hs-module Web.Spock.StaticMiddleware- ( -- * Middlewares- static, staticPolicy- , -- * Policies- Policy, (<|>), (>->), policy, predicate- , addBase, addSlash, contains, hasPrefix, hasSuffix, noDots, only- , -- * Utilities- tryPolicy- ) where--import Control.Monad.Trans (liftIO)-import qualified Data.ByteString as B-import Data.List-import qualified Data.Map as M-import Data.Maybe (fromMaybe)-import Data.Monoid-import qualified Data.Text as T--import Network.HTTP.Types (status200)-import System.Directory (doesFileExist)-import qualified System.FilePath as FP--import Network.Wai---- | Take an incoming URI and optionally modify or filter it.--- The result will be treated as a filepath.-newtype Policy = Policy { tryPolicy :: String -> Maybe String -- ^ Run a policy- }---- | Note:--- 'mempty' == @policy Just@ (the always accepting policy)--- 'mappend' == @>->@ (policy sequencing)-instance Monoid Policy where- mempty = policy Just- mappend p1 p2 = policy (maybe Nothing (tryPolicy p2) . tryPolicy p1)---- | Lift a function into a 'Policy'-policy :: (String -> Maybe String) -> Policy-policy = Policy---- | Lift a predicate into a 'Policy'-predicate :: (String -> Bool) -> Policy-predicate p = policy (\s -> if p s then Just s else Nothing)---- | Sequence two policies. They are run from left to right. (Note: this is `mappend`)-infixr 5 >->-(>->) :: Policy -> Policy -> Policy-(>->) = mappend---- | Choose between two policies. If the first fails, run the second.-infixr 4 <|>-(<|>) :: Policy -> Policy -> Policy-p1 <|> p2 = policy (\s -> maybe (tryPolicy p2 s) Just (tryPolicy p1 s))---- | Add a base path to the URI------ > staticPolicy (addBase "/home/user/files")------ GET \"foo\/bar\" looks for \"\/home\/user\/files\/foo\/bar\"----addBase :: String -> Policy-addBase b = policy (Just . (b FP.</>))---- | Add an initial slash to to the URI, if not already present.------ > staticPolicy addSlash------ GET \"foo\/bar\" looks for \"\/foo\/bar\"-addSlash :: Policy-addSlash = policy slashOpt- where slashOpt s@('/':_) = Just s- slashOpt s = Just ('/':s)---- | Accept only URIs with given suffix-hasSuffix :: String -> Policy-hasSuffix suf = predicate (isSuffixOf suf)---- | Accept only URIs with given prefix-hasPrefix :: String -> Policy-hasPrefix pre = predicate (isPrefixOf pre)---- | Accept only URIs containing given string-contains :: String -> Policy-contains s = predicate (isInfixOf s)---- | Reject URIs containing \"..\"-noDots :: Policy-noDots = predicate (not . isInfixOf "..")---- | Use URI as the key to an association list, rejecting those not found.--- The policy result is the matching value.------ > staticPolicy (only [("foo/bar", "/home/user/files/bar")])------ GET \"foo\/bar\" looks for \"\/home\/user\/files\/bar\"--- GET \"baz\/bar\" doesn't match anything----only :: [(String,String)] -> Policy-only al = policy (flip lookup al)---- | Serve static files out of the application root (current directory).--- If file is found, it is streamed to the client and no further middleware is run.-static :: Middleware-static = staticPolicy mempty---- | Serve static files subject to a 'Policy'-staticPolicy :: Policy -> Middleware-staticPolicy p app req =- maybe (app req)- (\fp -> do exists <- liftIO $ doesFileExist fp- if exists- then return $ ResponseFile status200- [("Content-Type", getMimeType fp)]- fp- Nothing- else app req)- (tryPolicy p $ T.unpack $ T.intercalate "/" $ pathInfo req)--type Ascii = B.ByteString--getMimeType :: FilePath -> Ascii-getMimeType = go . extensions- where go [] = defaultMimeType- go (ext:exts) = fromMaybe (go exts) $ M.lookup ext defaultMimeTypes--extensions :: FilePath -> [String]-extensions [] = []-extensions fp = case dropWhile (/= '.') fp of- [] -> []- s -> let ext = tail s- in ext : extensions ext--defaultMimeType :: Ascii-defaultMimeType = "application/octet-stream"---- This list taken from snap-core's Snap.Util.FileServe-defaultMimeTypes :: M.Map String Ascii-defaultMimeTypes = M.fromList [- ( "asc" , "text/plain" ),- ( "asf" , "video/x-ms-asf" ),- ( "asx" , "video/x-ms-asf" ),- ( "avi" , "video/x-msvideo" ),- ( "bz2" , "application/x-bzip" ),- ( "c" , "text/plain" ),- ( "class" , "application/octet-stream" ),- ( "conf" , "text/plain" ),- ( "cpp" , "text/plain" ),- ( "css" , "text/css" ),- ( "cxx" , "text/plain" ),- ( "dtd" , "text/xml" ),- ( "dvi" , "application/x-dvi" ),- ( "gif" , "image/gif" ),- ( "gz" , "application/x-gzip" ),- ( "hs" , "text/plain" ),- ( "htm" , "text/html" ),- ( "html" , "text/html" ),- ( "jar" , "application/x-java-archive" ),- ( "jpeg" , "image/jpeg" ),- ( "jpg" , "image/jpeg" ),- ( "js" , "text/javascript" ),- ( "json" , "application/json" ),- ( "log" , "text/plain" ),- ( "m3u" , "audio/x-mpegurl" ),- ( "mov" , "video/quicktime" ),- ( "mp3" , "audio/mpeg" ),- ( "mpeg" , "video/mpeg" ),- ( "mpg" , "video/mpeg" ),- ( "ogg" , "application/ogg" ),- ( "pac" , "application/x-ns-proxy-autoconfig" ),- ( "pdf" , "application/pdf" ),- ( "png" , "image/png" ),- ( "ps" , "application/postscript" ),- ( "qt" , "video/quicktime" ),- ( "sig" , "application/pgp-signature" ),- ( "spl" , "application/futuresplash" ),- ( "svg" , "image/svg+xml" ),- ( "swf" , "application/x-shockwave-flash" ),- ( "tar" , "application/x-tar" ),- ( "tar.bz2" , "application/x-bzip-compressed-tar" ),- ( "tar.gz" , "application/x-tgz" ),- ( "tbz" , "application/x-bzip-compressed-tar" ),- ( "text" , "text/plain" ),- ( "tgz" , "application/x-tgz" ),- ( "torrent" , "application/x-bittorrent" ),- ( "ttf" , "application/x-font-truetype" ),- ( "txt" , "text/plain" ),- ( "wav" , "audio/x-wav" ),- ( "wax" , "audio/x-ms-wax" ),- ( "wma" , "audio/x-ms-wma" ),- ( "wmv" , "video/x-ms-wmv" ),- ( "xbm" , "image/x-xbitmap" ),- ( "xml" , "text/xml" ),- ( "xpm" , "image/x-xpixmap" ),- ( "xwd" , "image/x-xwindowdump" ),- ( "zip" , "application/zip" ) ]