]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/StaticFile.hs
Added inputForm
[Lucu.git] / Network / HTTP / Lucu / StaticFile.hs
1 module Network.HTTP.Lucu.StaticFile
2     ( staticFile       -- FilePath -> ResourceDef
3     , handleStaticFile -- FilePath -> Resource ()
4
5     , staticDir       -- FilePath -> ResourceDef
6     , handleStaticDir -- FilePath -> Resource ()
7     )
8     where
9
10 import           Control.Monad
11 import           Control.Monad.Trans
12 import qualified Data.ByteString.Lazy.Char8 as B
13 import           Data.ByteString.Lazy.Char8 (ByteString)
14 import           Network.HTTP.Lucu.Abortion
15 import           Network.HTTP.Lucu.Config
16 import           Network.HTTP.Lucu.ETag
17 import           Network.HTTP.Lucu.MIMEType.Guess
18 import           Network.HTTP.Lucu.Resource
19 import           Network.HTTP.Lucu.Resource.Tree
20 import           Network.HTTP.Lucu.Response
21 import           Network.HTTP.Lucu.Utils
22 import           System.Directory
23 import           System.Posix.Files
24 import           Text.Printf
25
26
27 staticFile :: FilePath -> ResourceDef
28 staticFile path
29     = ResourceDef {
30         resUsesNativeThread = False
31       , resIsGreedy         = False
32       , resGet              = Just $ handleStaticFile path
33       , resHead             = Nothing
34       , resPost             = Nothing
35       , resPut              = Nothing
36       , resDelete           = Nothing
37       }
38
39
40 handleStaticFile :: FilePath -> Resource ()
41 handleStaticFile path
42     = do isFile <- liftIO $ doesFileExist path
43          if isFile then
44              -- 存在はした。讀めるかどうかは知らない。
45              do readable <- liftIO $ fileAccess path True False False
46                 unless readable
47                            -- 讀めない
48                            $ abort Forbidden [] Nothing
49
50                 -- 讀める
51                 tag      <- liftIO $ generateETagFromFile path
52                 lastMod  <- liftIO $ getModificationTime path
53                 foundEntity tag lastMod
54
55                 -- MIME Type を推定
56                 conf <- getConfig
57                 case guessTypeByFileName (cnfExtToMIMEType conf) path of
58                   Nothing   -> return ()
59                   Just mime -> setContentType mime
60
61                 -- 實際にファイルを讀んで送る
62                 (liftIO $ B.readFile path) >>= outputBS
63            else
64              do isDir <- liftIO $ doesDirectoryExist path
65                 if isDir then
66                     abort Forbidden [] Nothing
67                   else
68                     foundNoEntity Nothing
69
70
71 -- inode-size-lastmod
72 generateETagFromFile :: FilePath -> IO ETag
73 generateETagFromFile path
74     = do stat <- getFileStatus path
75          let inode   = fromEnum $ fileID   stat
76              size    = fromEnum $ fileSize stat
77              lastmod = fromEnum $ modificationTime stat
78          return $ strongETag $ printf "%x-%x-%x" inode size lastmod
79
80
81 staticDir :: FilePath -> ResourceDef
82 staticDir path
83     = ResourceDef {
84         resUsesNativeThread = False
85       , resIsGreedy         = True
86       , resGet              = Just $ handleStaticDir path
87       , resHead             = Nothing
88       , resPost             = Nothing
89       , resPut              = Nothing
90       , resDelete           = Nothing
91       }
92
93
94 handleStaticDir :: FilePath -> Resource ()
95 handleStaticDir basePath
96     = do extraPath <- getPathInfo
97          securityCheck extraPath
98          let path = basePath ++ "/" ++ joinWith "/" extraPath
99
100          handleStaticFile path
101     where
102       securityCheck :: Monad m => [String] -> m ()
103       securityCheck pathElems
104           = when (any (== "..") pathElems) $ fail ("security error: "
105                                                    ++ joinWith "/" pathElems)