mighttpd-0.1.0: File.hs

module File (mighty, progName) where

import Control.Applicative
import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.List
import Data.Time
import Data.Time.Clock.POSIX
import IO
import Network.TCPInfo
import Network.URI
import Network.Web.Server
import Network.Web.Server.Basic
import Network.Web.Utils
import System.Directory
import System.FilePath
import System.Posix.Files
import URLMap

progName :: String
progName = "Mighttpd"

progVersion :: String
progVersion = "0.1.0"

progNameVersion :: String
progNameVersion = progName ++ " " ++ progVersion

----------------------------------------------------------------

mighty :: WebConfig -> URLMap -> Handle -> TCPInfo -> IO ()
mighty wcnf umap hdl tcpinfo = do
  let bcnf = BasicConfig { obtain = fileGet
                         , info   = fileInfo
                         , mapper = fileMapper umap
                         , serverName = progNameVersion
                         , tcpInfo = tcpinfo
                         }
  connection hdl (basicServer bcnf) wcnf

----------------------------------------------------------------

lookupFileMap :: URLMap -> URL -> Path
lookupFileMap [] _          = None
lookupFileMap ((from,to):xs) url
    | from `isPrefixOf` url = toPath to $ drop (length from) url
    | otherwise             = lookupFileMap xs url
  where
    toPath (File dir) restPath = File $ dir </> restPath
    toPath (CGI dir _ urlPath) progParam = CGI prog param scriptName
      where
        (prog',param) = break (\x -> x == '?' || x == '/') progParam
        prog = dir </> prog'
        scriptName = urlPath </> prog'
    toPath _ _ = error "toPath"

fileMapper :: URLMap -> URI -> Path
fileMapper umap uri = fileMapper' (lookupFileMap umap url)
  where
    url = unEscapeString $ toURLwoPort uri
    fileMapper' None                  = None
    fileMapper' cgi@(CGI _ _ _)       = cgi
    fileMapper' (File file)
      | hasTrailingPathSeparator file = File $ file </> "index.html"
      | otherwise                     = File file

fileGet :: FilePath -> Maybe (Integer,Integer) -> IO ByteString
fileGet file Nothing = openFile file ReadMode >>= LBS.hGetContents
fileGet file (Just (skip,len)) = do
    h <- openFile file ReadMode
    hSeek h AbsoluteSeek skip
    LBS.take (fromIntegral len) <$> LBS.hGetContents h

fileInfo :: FilePath -> IO (Maybe (Integer, UTCTime))
fileInfo file = do
    exist <- doesFileExist file
    if exist
       then do
         fs <- getFileStatus file
         let size = fromIntegral . fileSize $ fs
             mtime = posixSecondsToUTCTime . realToFrac . modificationTime $ fs
         return $ Just (size, mtime)
       else return Nothing