FileServe.hs

{-# OPTIONS -fglasgow-exts #-}
module HAppS.Server.HTTP.FileServe
    (
     MimeMap,fileServe, mimeTypes,isDot, blockDotFiles,doIndex,errorwrapper
    ) where

import Control.Exception
import Control.Monad.Reader
import Control.Monad.Trans
import Data.List
import Data.Maybe
import HAppS.Server.SimpleHTTP
import System.Directory
import System.IO
import System.Locale(defaultTimeLocale)
import System.Log.Logger
import System.Time -- (formatCalendarTime, toUTCTime,TOD(..))
import qualified Data.ByteString.Char8 as P
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Map as Map
import qualified HAppS.Server.SimpleHTTP as SH

-- mapResult :: (IO Result -> IO Result) -> [ServerPart] -> ServerPart
-- mapResult fn parts = ReaderT $ \rq -> fmap fn (runReaderT (multi parts) rq

errorwrapper :: MonadIO m => String -> String -> ServerPartT m Response
errorwrapper binarylocation loglocation
    = require getErrorLog $ \errorLog ->
      --[method () $ SH.ok errorLog]
      [anyRequest $ liftIO $ return $ toResponse errorLog]
    where getErrorLog
              = liftIO $
                handleJust ioErrors (const (return Nothing)) $
                do bintime <- getModificationTime binarylocation
                   logtime <- getModificationTime loglocation
                   if (logtime > bintime)
                     then fmap Just $ readFile loglocation -- fileServe [loglocation] [] "./"
                     else return Nothing

type MimeMap = Map.Map String String

doIndex [] _mime _rq _fp = do setResponseCode 403
                              return $ toResponse "Directory index forbidden"
doIndex (index:rest) mime rq fp =
    do
    let path = fp++'/':index
    --print path
    fe <- liftIO $ doesFileExist path
    if fe then retFile path else doIndex rest mime rq fp
    where retFile = returnFile mime rq
defaultIxFiles= ["index.html","index.xml","index.gif"]

fileServe :: MonadIO m => [FilePath] -> FilePath -> ServerPartT m Response
fileServe ixFiles localpath  = 
    withRequest (fileServe' localpath (doIndex (ixFiles++defaultIxFiles)) mimeTypes)

-- | Serve files with a mime type map under a directory.
--   Uses the function to transform URIs to FilePaths.
fileServe' localpath fdir mime rq = do
    let fp2 = takeWhile (/=',') fp
        fp = filepath
        safepath = filter (\x->not (null x) && head x /= '.') (rqPaths rq)
        filepath = intercalate "/"  (localpath:safepath)
        fp' = if null safepath then "" else last safepath
    if "TESTH" `isPrefixOf` fp'
        then renderResponse mime rq $ fakeFile $ read $ drop 5 $ fp' 
        else do
    fe <- liftIO $ doesFileExist fp
    fe2 <- liftIO $ doesFileExist fp2
    de <- liftIO $ doesDirectoryExist fp
    -- error $ "show ilepath: " ++show (fp,de)
    let status | de   = "DIR"
               | fe   = "file"
               | fe2  = "group"
               | True = "NOT FOUND"
    liftIO $ logM "HAppS.Server.HTTP.FileServe" INFO ("fileServe: "++show fp++" \t"++status)
    if de then fdir mime rq fp else do
    getFile mime fp >>= flip either (renderResponse mime rq) 
                (const $ returnGroup localpath mime rq safepath)

returnFile mime rq fp =  
    getFile mime fp >>=  either fileNotFound (renderResponse mime rq)

--- #if fp has , separated then return concatenation with content-type of last
-- #and last modified of latest
tr a b list = map (\x->if x==a then b else x) list
ltrim = dropWhile (flip elem " \t\r")   

returnGroup localPath mime rq fp = do
  let fps0 = map ((:[]). ltrim) $ lines $ tr ',' '\n' $ last fp
      fps = map (intercalate "/" . ((localPath:init fp) ++)) fps0

  -- if (head $ head fps0)=="TEST" then   renderResponse mime rq fakeFile else do

  mbFiles <-  mapM (getFile mime) $ fps
  let notFounds = [x | Left x <- mbFiles]
      files = [x | Right x <- mbFiles]
  if not $ null notFounds 
    then fileNotFound $ drop (length localPath) $ head notFounds else do
  let totSize = sum $ map (snd . fst) files
      maxTime::ClockTime = maximum $ map (fst . fst) files

  renderResponse mime rq ((maxTime,totSize),(fst $ snd $ head files,
                                             L.concat $ map (snd . snd) files))



fileNotFound fp = do setResponseCode 404 
                     return $ toResponse $ "File not found "++ fp
--fakeLen = 71* 1024
fakeFile fakeLen = ((TOD 0 0,L.length body),("text/javascript",body))
    where
      body = L.pack $ (("//"++(show len)++" ") ++ ) $ (take len $ repeat '0') ++ "\n"
      len = fromIntegral fakeLen

getFile mime fp = do
  let ct = Map.findWithDefault "text/plain" (getExt fp) mime
  fe <- liftIO $ doesFileExist fp
  if not fe then return $ Left fp else do
  
  time <- liftIO  $ getModificationTime fp
  h <- liftIO $ openBinaryFile fp ReadMode
  size <- liftIO $ hFileSize h
  lbs <- liftIO $ L.hGetContents h
  return $ Right ((time,size),(ct,lbs))



renderResponse mime rq ((modtime,size),(ct,body)) = do

  let notmodified = getHeader "if-modified-since" rq == Just (P.pack $ repr)
      repr = formatCalendarTime defaultTimeLocale 
             "%a, %d %b %Y %X GMT" (toUTCTime modtime)
  -- "Mon, 07 Jan 2008 19:51:02 GMT"
  -- when (isJust $ getHeader "if-modified-since"  rq) $ error $ show $ getHeader "if-modified-since" rq
  if notmodified then do setResponseCode 304 ; return $ toResponse "" else do
  let mod = getHeader "if-modified-since" rq
  modifyResponse (setHeader "HUH" $ show $ (fmap P.unpack mod == Just repr,mod,Just repr))
  modifyResponse (setHeader "Last-modified" repr)
  -- if %Z or UTC are in place of GMT below, wget complains that the last-modified header is invalid
  modifyResponse (setHeader "Content-Length" (show size))
  modifyResponse (setHeader "Content-Type" ct)  
  return $ resultBS 200 body

              


getExt fPath = reverse $ takeWhile (/='.') $ reverse fPath

-- | Ready collection of common mime types.
mimeTypes :: MimeMap
mimeTypes = Map.fromList
	    [("xml","application/xml")
	    ,("xsl","application/xml")
	    ,("js","text/javascript")
	    ,("html","text/html")
	    ,("css","text/css")
	    ,("gif","image/gif")
	    ,("jpg","image/jpeg")
	    ,("png","image/png")
	    ,("txt","text/plain")
	    ,("doc","application/msword")
	    ,("exe","application/octet-stream")
	    ,("pdf","application/pdf")
	    ,("zip","application/zip")
	    ,("gz","application/x-gzip")
	    ,("ps","application/postscript")
	    ,("rtf","application/rtf")
	    ,("wav","application/x-wav")
	    ,("hs","text/plain")]



blockDotFiles :: (Request -> IO Response) -> Request -> IO Response
blockDotFiles fn rq
    | isDot (intercalate "/" (rqPaths rq)) = return $ result 403 "Dot files not allowed."
    | otherwise = fn rq

isDot = isD . reverse
    where
    isD ('.':'/':_) = True
    isD ['.']       = True
    --isD ('/':_)     = False
    isD (_:cs)      = isD cs
    isD []          = False