X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FStaticFile.hs;h=12cf78b0729c760c82e6f35faa08909f6d53b876;hb=0dc3d31312a12f2b085242841b29eb0d96e9c4ac;hp=cbbed1e8e44bdbb44f88ef0a3019ad5137b67217;hpb=c6b11025d1f81c668e9995e856b7bb34175230d3;p=Lucu.git

diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs
index cbbed1e..12cf78b 100644
--- a/Network/HTTP/Lucu/StaticFile.hs
+++ b/Network/HTTP/Lucu/StaticFile.hs
@@ -1,13 +1,149 @@
+-- | Handling static files on the filesystem.
 module Network.HTTP.Lucu.StaticFile
-    (
+    ( staticFile
+    , handleStaticFile
+
+    , staticDir
+    , handleStaticDir
+
+    , generateETagFromFile
     )
     where
 
+import           Control.Monad
+import           Control.Monad.Trans
+import qualified Data.ByteString.Lazy.Char8 as B
+import           Network.HTTP.Lucu.Abortion
+import           Network.HTTP.Lucu.Config
+import           Network.HTTP.Lucu.ETag
+import           Network.HTTP.Lucu.Format
+import           Network.HTTP.Lucu.MIMEType.Guess
+import           Network.HTTP.Lucu.Resource
+import           Network.HTTP.Lucu.Resource.Tree
+import           Network.HTTP.Lucu.Response
+import           Network.HTTP.Lucu.Utils
+import           System.Directory
+import           System.Posix.Files
 
+
+-- | @'staticFile' fpath@ is a
+-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' which serves the file
+-- at @fpath@ on the filesystem.
 staticFile :: FilePath -> ResourceDef
 staticFile path
     = ResourceDef {
         resUsesNativeThread = False
       , resIsGreedy         = False
-      , resGet
-          = Just $ do 
\ No newline at end of file
+      , resGet              = Just $! handleStaticFile path
+      , resHead             = Nothing
+      , resPost             = Nothing
+      , resPut              = Nothing
+      , resDelete           = Nothing
+      }
+
+-- | Computation of @'handleStaticFile' fpath@ serves the file at
+-- @fpath@ on the filesystem. The
+-- 'Network.HTTP.Lucu.Resource.Resource' must be in the /Examining
+-- Request/ state before the computation. It will be in the /Done/
+-- state after the computation.
+--
+-- If you just want to place a static file on the
+-- 'Network.HTTP.Lucu.Resource.Tree.ResTree', you had better use
+-- 'staticFile' instead of this.
+handleStaticFile :: FilePath -> Resource ()
+handleStaticFile path
+    = path `seq`
+      do isFile <- liftIO $ doesFileExist path
+         if isFile then
+             -- 存在はした。讀めるかどうかは知らない。
+             do readable <- liftIO $ fileAccess path True False False
+                unless readable
+                           -- 讀めない
+                           $ abort Forbidden [] Nothing
+
+                -- 讀める
+                tag      <- liftIO $ generateETagFromFile path
+                lastMod  <- liftIO $ getModificationTime path
+                foundEntity tag lastMod
+
+                -- MIME Type を推定
+                conf <- getConfig
+                case guessTypeByFileName (cnfExtToMIMEType conf) path of
+                  Nothing   -> return ()
+                  Just mime -> setContentType mime
+
+                -- 實際にファイルを讀んで送る
+                (liftIO $ B.readFile path) >>= outputLBS
+           else
+             do isDir <- liftIO $ doesDirectoryExist path
+                if isDir then
+                    abort Forbidden [] Nothing
+                  else
+                    foundNoEntity Nothing
+
+-- |Computation of @'generateETagFromFile' fpath@ generates a strong
+-- entity tag from a file. The file doesn't necessarily have to be a
+-- regular file; it may be a FIFO or a device file. The tag is made of
+-- inode ID, size and modification time.
+--
+-- Note that the tag is not strictly strong because the file could be
+-- modified twice at a second without changing inode ID or size, but
+-- it's not really possible to generate a strict strong ETag from a
+-- file since we don't want to simply grab the entire file and use it
+-- as an ETag. It is indeed possible to hash it with SHA-1 or MD5 to
+-- increase strictness, but it's too inefficient if the file is really
+-- large (say, 1 TiB).
+generateETagFromFile :: FilePath -> IO ETag
+generateETagFromFile path
+    = path `seq`
+      do stat <- getFileStatus path
+         let inode   = fromEnum $! fileID   stat
+             size    = fromEnum $! fileSize stat
+             lastMod = fromEnum $! modificationTime stat
+             tag     = fmtHex False 0 inode
+                       ++ "-" ++
+                       fmtHex False 0 size
+                       ++ "-" ++
+                       fmtHex False 0 lastMod
+         return $! strongETag tag
+
+-- | @'staticDir' dir@ is a
+-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' which maps all files
+-- in @dir@ and its subdirectories on the filesystem to the
+-- 'Network.HTTP.Lucu.Resource.Tree.ResTree'.
+staticDir :: FilePath -> ResourceDef
+staticDir path
+    = ResourceDef {
+        resUsesNativeThread = False
+      , resIsGreedy         = True
+      , resGet              = Just $! handleStaticDir path
+      , resHead             = Nothing
+      , resPost             = Nothing
+      , resPut              = Nothing
+      , resDelete           = Nothing
+      }
+
+-- | Computation of @'handleStaticDir' dir@ maps all files in @dir@
+-- and its subdirectories on the filesystem to the
+-- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The
+-- 'Network.HTTP.Lucu.Resource.Resource' must be in the /Examining
+-- Request/ state before the computation. It will be in the /Done/
+-- state after the computation.
+--
+-- If you just want to place a static directory tree on the
+-- 'Network.HTTP.Lucu.Resource.Tree.ResTree', you had better use
+-- 'staticDir' instead of this.
+handleStaticDir :: FilePath -> Resource ()
+handleStaticDir basePath
+    = basePath `seq`
+      do extraPath <- getPathInfo
+         securityCheck extraPath
+         let path = basePath ++ "/" ++ joinWith "/" extraPath
+
+         handleStaticFile path
+    where
+      securityCheck :: Monad m => [String] -> m ()
+      securityCheck pathElems
+          = pathElems `seq`
+            when (any (== "..") pathElems) $ fail ("security error: "
+                                                   ++ joinWith "/" pathElems)