-
Notifications
You must be signed in to change notification settings - Fork 3
/
File.hs
91 lines (78 loc) · 2.87 KB
/
File.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
{-# LANGUAGE OverloadedStrings #-}
module File (mighty, progName, fileMapper) where -- xxx
import Control.Applicative
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
import Data.List
import Data.Time
import Data.Time.Clock.POSIX
import Network.TCPInfo
import Network.Web.Server
import Network.Web.Server.Basic
import Network.Web.URI
import System.Directory
import System.FilePath
import System.IO
import System.Posix.Files
import URLMap
progName :: String
progName = "Mighttpd"
progVersion :: String
progVersion = "0.4.3"
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 = S.pack progNameVersion
, tcpInfo = tcpinfo
}
connection hdl (basicServer bcnf) wcnf
----------------------------------------------------------------
lookupFileMap :: URLMap -> URL -> Maybe (URL,ConvInfo)
lookupFileMap [] _ = Nothing
lookupFileMap (ent@(from,_):xs) url
| from `isPrefixOf` url = Just ent
| otherwise = lookupFileMap xs url
fileMapper :: URLMap -> URI -> Path
fileMapper umap uri = case lookupFileMap umap url of
Nothing -> None
Just (curl,cinfo) -> fileMapper' uri url curl cinfo
where
url = unEscapeString . S.unpack . toURLPath $ uri -- without param
fileMapper' :: URI -> URL -> URL -> ConvInfo -> Path
fileMapper' uri url curl cinfo = case cinfo of
CIFile dir -> toFile (dir </> path0)
CICgi dir path -> toCGI dir path
where
path0 = drop (length curl) url
toFile path
| hasTrailingPathSeparator path = File (path </> "index.html")
| otherwise = File path
toCGI dir path = PathCGI CGI {
progPath = dir </> prog
, scriptName = path </> prog
, pathInfo = pathinfo
, queryString = unEscapeString . S.unpack $ uriQuery uri
}
where
(prog,pathinfo) = break (== '/') path0
fileGet :: FilePath -> Maybe (Integer,Integer) -> IO L.ByteString
fileGet file Nothing = openFile file ReadMode >>= L.hGetContents
fileGet file (Just (skip,len)) = do
h <- openFile file ReadMode
hSeek h AbsoluteSeek skip
L.take (fromIntegral len) <$> L.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