]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/StaticFile.hs
5289f5fdb8cd374c88a594e30ce0c6542e633d5a
[Lucu.git] / Network / HTTP / Lucu / StaticFile.hs
1 {-# LANGUAGE
2     BangPatterns
3   , UnicodeSyntax
4   #-}
5 -- | Handling static files on the filesystem.
6 module Network.HTTP.Lucu.StaticFile
7     ( staticFile
8     , handleStaticFile
9
10     , staticDir
11     , handleStaticDir
12
13     , generateETagFromFile
14     )
15     where
16 import           Control.Monad
17 import           Control.Monad.Trans
18 import qualified Data.ByteString.Lazy.Char8 as B
19 import           Data.Time.Clock.POSIX
20 import           Network.HTTP.Lucu.Abortion
21 import           Network.HTTP.Lucu.Config
22 import           Network.HTTP.Lucu.ETag
23 import           Network.HTTP.Lucu.Format
24 import           Network.HTTP.Lucu.MIMEType.Guess
25 import           Network.HTTP.Lucu.Resource
26 import           Network.HTTP.Lucu.Resource.Tree
27 import           Network.HTTP.Lucu.Response
28 import           Network.HTTP.Lucu.Utils
29 import           System.FilePath.Posix
30 import           System.Posix.Files
31
32 -- | @'staticFile' fpath@ is a 'ResourceDef' which serves the file at
33 -- @fpath@ on the filesystem.
34 staticFile :: FilePath -> ResourceDef
35 staticFile path
36     = ResourceDef {
37         resUsesNativeThread = False
38       , resIsGreedy         = False
39       , resGet              = Just $! handleStaticFile path
40       , resHead             = Nothing
41       , resPost             = Nothing
42       , resPut              = Nothing
43       , resDelete           = Nothing
44       }
45
46 -- | Computation of @'handleStaticFile' fpath@ serves the file at
47 -- @fpath@ on the filesystem. The
48 -- 'Network.HTTP.Lucu.Resource.Resource' must be in the /Examining
49 -- Request/ state before the computation. It will be in the /Done/
50 -- state after the computation.
51 --
52 -- If you just want to place a static file on the
53 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree', you had better use
54 -- 'staticFile' instead of this.
55 handleStaticFile :: FilePath -> Resource ()
56 handleStaticFile path
57     = path `seq`
58       do exists <- liftIO $ fileExist path
59          if exists then
60              -- 存在はした。讀めるかどうかは知らない。
61              do stat <- liftIO $ getFileStatus path
62                 if isRegularFile stat then
63                     do readable <- liftIO $ fileAccess path True False False
64                        unless readable
65                            -- 讀めない
66                            $ abort Forbidden [] Nothing
67                        -- 讀める
68                        tag     <- liftIO $ generateETagFromFile path
69                        let lastMod = posixSecondsToUTCTime $ fromRational $ toRational $ modificationTime stat
70                        foundEntity tag lastMod
71
72                        -- MIME Type を推定
73                        conf <- getConfig
74                        case guessTypeByFileName (cnfExtToMIMEType conf) path of
75                          Nothing   -> return ()
76                          Just mime -> setContentType mime
77
78                        -- 實際にファイルを讀んで送る
79                        liftIO (B.readFile path) >>= outputLBS
80                   else
81                     abort Forbidden [] Nothing
82            else
83              foundNoEntity Nothing
84
85
86 -- |Computation of @'generateETagFromFile' fpath@ generates a strong
87 -- entity tag from a file. The file doesn't necessarily have to be a
88 -- regular file; it may be a FIFO or a device file. The tag is made of
89 -- inode ID, size and modification time.
90 --
91 -- Note that the tag is not strictly strong because the file could be
92 -- modified twice at a second without changing inode ID or size, but
93 -- it's not really possible to generate a strict strong ETag from a
94 -- file since we don't want to simply grab the entire file and use it
95 -- as an ETag. It is indeed possible to hash it with SHA-1 or MD5 to
96 -- increase strictness, but it's too inefficient if the file is really
97 -- large (say, 1 TiB).
98 generateETagFromFile :: FilePath -> IO ETag
99 generateETagFromFile path
100     = path `seq`
101       do stat <- getFileStatus path
102          let inode   = fromEnum $! fileID   stat
103              size    = fromEnum $! fileSize stat
104              lastMod = fromEnum $! modificationTime stat
105              tag     = fmtHex False 0 inode
106                        ++ "-" ++
107                        fmtHex False 0 size
108                        ++ "-" ++
109                        fmtHex False 0 lastMod
110          return $! strongETag tag
111
112 -- | @'staticDir' dir@ is a
113 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' which maps all files
114 -- in @dir@ and its subdirectories on the filesystem to the
115 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'.
116 staticDir :: FilePath -> ResourceDef
117 staticDir path
118     = ResourceDef {
119         resUsesNativeThread = False
120       , resIsGreedy         = True
121       , resGet              = Just $! handleStaticDir path
122       , resHead             = Nothing
123       , resPost             = Nothing
124       , resPut              = Nothing
125       , resDelete           = Nothing
126       }
127
128 -- | Computation of @'handleStaticDir' dir@ maps all files in @dir@
129 -- and its subdirectories on the filesystem to the
130 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The
131 -- 'Network.HTTP.Lucu.Resource.Resource' must be in the /Examining
132 -- Request/ state before the computation. It will be in the /Done/
133 -- state after the computation.
134 --
135 -- If you just want to place a static directory tree on the
136 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree', you had better use
137 -- 'staticDir' instead of this.
138 handleStaticDir :: FilePath -> Resource ()
139 handleStaticDir !basePath
140     = do extraPath <- getPathInfo
141          securityCheck extraPath
142          let path = basePath </> joinPath extraPath
143
144          handleStaticFile path
145     where
146       securityCheck :: Monad m => [String] -> m ()
147       securityCheck !pathElems
148           = when (any (== "..") pathElems) $ fail ("security error: "
149                                                    ++ joinWith "/" pathElems)
150 -- TODO: implement directory listing.