{- | A file server for frequently accessed files, such are static web pages and image decorations, icons etc that are cached (memoized) according with the "Data.TCache" policies in the program space. This avoid the blocking of the efficient GHC threads by frequent IO calls.So it enhances the performance in the context of heavy concurrence. It uses 'Data.TCache.Memoization'. The caching-uncaching follows the `setPersist` criteria. -} ----------------------------------------------------------------------------- -- -- Module : FileServer -- Copyright : -- License : BSD3 -- -- Maintainer : agocorona@gmail.com -- Stability : experimental -- Portability : -- -- -- ----------------------------------------------------------------------------- {-# OPTIONS -XScopedTypeVariables #-} module MFlow.FileServer (addFileServerWF, linkFile,setFilesPath ) where import MFlow import Control.Monad.State import Data.TCache.Memoization import MFlow.Forms.XHtml import System.Directory import Data.ByteString.Lazy.Char8 as B(readFile,concat,append,pack,empty) import Control.Exception as CE import Data.Char import Data.List import System.IO.Unsafe import Data.IORef import Data.Monoid --import Debug.Trace --(!>)= flip trace rfilesPath= unsafePerformIO $ newIORef "files/" -- | Set the path of the files in the web server. The links to the files are relative to it setFilesPath :: String -> IO () setFilesPath path= writeIORef rfilesPath path pathPrm= "path" fileServe ::(Token -> Workflow IO ()) fileServe = stateless $ \env -> do case lookup pathPrm env of Nothing -> error " no file specified" Just path' ->do when(let hpath= head path' in hpath == '/' || hpath =='\\') $ error noperm when(not(".." `isSuffixOf` path') && ".." `isInfixOf` path') $ error noperm filesPath <- readIORef rfilesPath let path= filesPath ++ path' isDirectory <- doesDirectoryExist path -- !> path case isDirectory of True -> directory1 $ path ++ "/" False -> do isFile <- doesFileExist path case isFile of True -> servefile path False -> return . pack $ "path not found" where dropBack ".."= ".." dropBack path | "../" `isPrefixOf` revpath =reverse . maybetail $ dropWhile (/= '/') $ drop 3 revpath | otherwise= path where revpath= reverse path -- maybetail ""= "." maybetail xs= tail xs noperm= "no permissions" ioerr x= \(e :: CE.IOException) -> x servefile path= do mr <- cachedByKey path 0 $ (B.readFile path >>= return . Just) `CE.catch` ioerr (return Nothing) case mr of Nothing -> return . pack $ "no permissions" Just r -> return r -- let ext = reverse . takeWhile (/='.') $ reverse path -- mmime= lookup (map toLower ext) mimeTable -- mime = case mmime of Just m -> m ;Nothing -> "application/octet-stream" -- mimet= [("Content-Type",mime)] -- in return r -- $ HttpData mimet [] r -- | Is the flow to be added to the list in order to stream any file from the filesystem -- for example, images -- -- This app includes the fileServe flow: -- -- @ -- main= do -- addFileServerWF -- addMessageFlows messageFlows -- run 80 hackMessageFlow -- adminLoop -- where -- messageFlows= [(\"noscript\" , transient $ runFlow showStories) -- ,("\admin\" , transient $ runFlow admin) -- ,("\mail\" , transient $ runFlow mail)]@ -- -- Add the fileServer to the list of server flows addFileServerWF= addMessageFlows [("file", fileServe)] -- | Creates the url of file path. To be used in ordinary links to files. -- in Text.XHtml, a image would be embeded as -- -- > image ![src $ linkFile imagepath] -- -- in HSP: -- -- > -- | Given the relative path of a file, it return the content of the @href@ element in a html link linkFile :: String -> String linkFile path= "file?path=" <> path directory :: Token -> Workflow IO () directory = stateless $ \_ -> do path <- readIORef rfilesPath directory1 path directory1 path = do fs <- getDirectoryContents path return $ B.concat [btag "a" [("href",linkFile ( path ++ file))] (B.pack file) `append` btag "br" [] B.empty | file <- fs] {- mimeTable=[ ("html", "text/html"), ("htm", "text/html"), ("txt", "text/plain"), ("jpeg", "image/jpeg"), ("pdf", "application/pdf"), ("js", "application/x-javascript"), ("gif", "image/gif"), ("bmp", "image/bmp"), ("ico", "image/x-icon"), ("doc", "application/msword"), ("jpg", "image/jpeg"), ("eps", "application/postscript"), ("zip", "application/zip"), ("exe", "application/octet-stream"), ("tif", "image/tiff"), ("tiff", "image/tiff"), ("mov", "video/quicktime"), ("movie", "video/x-sgi-movie"), ("mp2", "video/mpeg"), ("mp3", "audio/mpeg"), ("mpa", "video/mpeg"), ("mpe", "video/mpeg"), ("mpeg", "video/mpeg"), ("mpg", "video/mpeg"), ("mpp", "application/vnd.ms-project"), ("323", "text/h323"), ("*", "application/octet-stream"), ("acx", "application/internet-property-stream"), ("ai", "application/postscript"), ("aif", "audio/x-aiff"), ("aifc", "audio/x-aiff"), ("aiff", "audio/x-aiff"), ("asf", "video/x-ms-asf"), ("asr", "video/x-ms-asf"), ("asx", "video/x-ms-asf"), ("au", "audio/basic"), ("avi", "video/x-msvideo"), ("axs", "application/olescript"), ("bas", "text/plain"), ("bcpio", "application/x-bcpio"), ("bin", "application/octet-stream"), ("c", "text/plain"), ("cat", "application/vnd.ms-pkiseccat"), ("cdf", "application/x-cdf"), ("cdf", "application/x-netcdf"), ("cer", "application/x-x509-ca-cert"), ("class", "application/octet-stream"), ("clp", "application/x-msclip"), ("cmx", "image/x-cmx"), ("cod", "image/cis-cod"), ("cpio", "application/x-cpio"), ("crd", "application/x-mscardfile"), ("crl", "application/pkix-crl"), ("crt", "application/x-x509-ca-cert"), ("csh", "application/x-csh"), ("css", "text/css"), ("dcr", "application/x-director"), ("der", "application/x-x509-ca-cert"), ("dir", "application/x-director"), ("dll", "application/x-msdownload"), ("dms", "application/octet-stream"), ("dot", "application/msword"), ("dvi", "application/x-dvi"), ("dxr", "application/x-director"), ("eps", "application/postscript"), ("etx", "text/x-setext"), ("evy", "application/envoy"), ("fif", "application/fractals"), ("flr", "x-world/x-vrml"), ("gtar", "application/x-gtar"), ("gz", "application/x-gzip"), ("h", "text/plain"), ("hdf", "application/x-hdf"), ("hlp", "application/winhlp"), ("hqx", "application/mac-binhex40"), ("hta", "application/hta"), ("htc", "text/x-component"), ("htt", "text/webviewhtml"), ("ief", "image/ief"), ("iii", "application/x-iphone"), ("ins", "application/x-internet-signup"), ("isp", "application/x-internet-signup"), ("jfif", "image/pipeg"), ("jpe", "image/jpeg"), ("latex", "application/x-latex"), ("lha", "application/octet-stream"), ("lsf", "video/x-la-asf"), ("lsx", "video/x-la-asf"), ("lzh", "application/octet-stream"), ("m13", "application/x-msmediaview"), ("m14", "application/x-msmediaview"), ("m3u", "audio/x-mpegurl"), ("man", "application/x-troff-man"), ("mdb", "application/x-msaccess"), ("me", "application/x-troff-me"), ("mht", "message/rfc822"), ("mhtml", "message/rfc822"), ("mid", "audio/mid"), ("mny", "application/x-msmoney"), ("mpv2", "video/mpeg"), ("ms", "application/x-troff-ms"), ("msg", "application/vnd.ms-outlook"), ("mvb", "application/x-msmediaview"), ("nc", "application/x-netcdf"), ("nws", "message/rfc822"), ("oda", "application/oda"), ("p10", "application/pkcs10"), ("p12", "application/x-pkcs12"), ("p7b", "application/x-pkcs7-certificates"), ("p7c", "application/x-pkcs7-mime"), ("p7m", "application/x-pkcs7-mime"), ("p7r", "application/x-pkcs7-certreqresp"), ("p7s", "application/x-pkcs7-signature"), ("pbm", "image/x-portable-bitmap"), ("pfx", "application/x-pkcs12"), ("pgm", "image/x-portable-graymap"), ("pko", "application/ynd.ms-pkipko"), ("pma", "application/x-perfmon"), ("pmc", "application/x-perfmon"), ("pml", "application/x-perfmon"), ("pmr", "application/x-perfmon"), ("pmw", "application/x-perfmon"), ("pnm", "image/x-portable-anymap"), ("pot", "application/vnd.ms-powerpoint"), ("ppm", "image/x-portable-pixmap"), ("pps", "application/vnd.ms-powerpoint"), ("ppt", "application/vnd.ms-powerpoint"), ("prf", "application/pics-rules"), ("ps", "application/postscript"), ("pub", "application/x-mspublisher"), ("qt", "video/quicktime"), ("ra", "audio/x-pn-realaudio"), ("ram", "audio/x-pn-realaudio"), ("ras", "image/x-cmu-raster"), ("rgb", "image/x-rgb"), ("rmi", "audio/mid"), ("roff", "application/x-troff"), ("rtf", "application/rtf"), ("rtx", "text/richtext"), ("scd", "application/x-msschedule"), ("sct", "text/scriptlet"), ("setpay", "application/set-payment-initiation"), ("setreg", "application/set-registration-initiation"), ("sh", "application/x-sh"), ("shar", "application/x-shar"), ("sit", "application/x-stuffit"), ("snd", "audio/basic"), ("spc", "application/x-pkcs7-certificates"), ("spl", "application/futuresplash"), ("src", "application/x-wais-source"), ("sst", "application/vnd.ms-pkicertstore"), ("stl", "application/vnd.ms-pkistl"), ("stm", "text/html"), ("sv4cpio", "application/x-sv4cpio"), ("sv4crc", "application/x-sv4crc"), ("svg", "image/svg+xml"), ("swf", "application/x-shockwave-flash"), ("t", "application/x-troff"), ("tar", "application/x-tar"), ("tcl", "application/x-tcl"), ("tex", "application/x-tex"), ("texi", "application/x-texinfo"), ("texinfo", "application/x-texinfo"), ("tgz", "application/x-compressed"), ("tr", "application/x-troff"), ("trm", "application/x-msterminal"), ("tsv", "text/tab-separated-values"), ("uls", "text/iuls"), ("ustar", "application/x-ustar"), ("vcf", "text/x-vcard"), ("vrml", "x-world/x-vrml"), ("wav", "audio/x-wav"), ("wcm", "application/vnd.ms-works"), ("wdb", "application/vnd.ms-works"), ("wks", "application/vnd.ms-works"), ("wmf", "application/x-msmetafile"), ("wps", "application/vnd.ms-works"), ("wri", "application/x-mswrite"), ("wrl", "x-world/x-vrml"), ("wrz", "x-world/x-vrml"), ("xaf", "x-world/x-vrml"), ("xbm", "image/x-xbitmap"), ("xla", "application/vnd.ms-excel"), ("xlc", "application/vnd.ms-excel"), ("xlm", "application/vnd.ms-excel"), ("xls", "application/vnd.ms-excel"), ("xlt", "application/vnd.ms-excel"), ("xlw", "application/vnd.ms-excel"), ("xof", "x-world/x-vrml"), ("xpm", "image/x-xpixmap"), ("xwd", "image/x-xwindowdump"), ("z", "application/x-compress") ] -}