Rename: Resource --> Rsrc; ResourceDef --> Resource

[Lucu.git] / Network / HTTP / Lucu / StaticFile.hs

diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs
index 89b783281b12bbfdf526fabcdc545c856e68ecec..5b5eb9734e3a68441516f36a86ada99269ea7888 100644 (file)
--- a/Network/HTTP/Lucu/StaticFile.hs
+++ b/Network/HTTP/Lucu/StaticFile.hs
@@ -1,70 +1,102 @@
+{-# LANGUAGE
+    DoAndIfThenElse
+  , OverloadedStrings
+  , QuasiQuotes
+  , UnicodeSyntax
+  #-}
+-- | Handling static files on the filesystem.
 module Network.HTTP.Lucu.StaticFile
-    ( staticFile       -- FilePath -> ResourceDef
-    , handleStaticFile -- FilePath -> Resource ()
+    ( staticFile
+    , staticDir
     )
     where
+import Control.Monad
+import Control.Monad.Unicode
+import Control.Monad.Trans
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as LBS
+import Data.String
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import Network.HTTP.Lucu.Abortion
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.MIMEType hiding (mimeType)
+import Network.HTTP.Lucu.MIMEType.Guess
+import Network.HTTP.Lucu.MIMEType.TH
+import Network.HTTP.Lucu.Resource
+import Network.HTTP.Lucu.Resource.Internal
+import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Utils
+import Prelude.Unicode
+import System.Directory
+import System.FilePath
 
-import           Control.Monad
-import           Control.Monad.Trans
-import qualified Data.ByteString.Lazy.Char8 as B
-import           Data.ByteString.Lazy.Char8 (ByteString)
-import           Network.HTTP.Lucu.Abortion
-import           Network.HTTP.Lucu.Config
-import           Network.HTTP.Lucu.ETag
-import           Network.HTTP.Lucu.MIMEType.Guess
-import           Network.HTTP.Lucu.Resource
-import           Network.HTTP.Lucu.Resource.Tree
-import           Network.HTTP.Lucu.Response
-import           System.Directory
-import           System.Posix.Files
-import           Text.Printf
-
-
-staticFile :: FilePath -> ResourceDef
+-- | @'staticFile' fpath@ is a 'Resource' which serves the file at
+-- @fpath@ on the filesystem.
+staticFile ∷ FilePath → Resource
 staticFile path
-    = ResourceDef {
-        resUsesNativeThread = False
-      , resIsGreedy         = False
-      , resGet              = Just $ handleStaticFile path
-      , resHead             = Nothing
-      , resPost             = Nothing
-      , resPut              = Nothing
-      , resDelete           = Nothing
+    = emptyResource {
+        resGet  = Just $ handleStaticFile True  path
+      , resHead = Just $ handleStaticFile False path
       }
 
+octetStream ∷ MIMEType
+octetStream = [mimeType| application/octet-stream |]
+
+handleStaticFile ∷ Bool → FilePath → Rsrc ()
+handleStaticFile sendContent path
+    = do isDir ← liftIO $ doesDirectoryExist path
+         when isDir
+             $ abort
+             $ mkAbortion Forbidden [] Nothing
+
+         isFile ← liftIO $ doesFileExist path
+         unless isFile
+             foundNoEntity'
 
-handleStaticFile :: FilePath -> Resource ()
-handleStaticFile path
-    = do exist <- liftIO $ fileExist path
-         if exist then
-             -- 存在はした。讀めるかどうかは知らない。
-             do readable <- liftIO $ fileAccess path True False False
-                unless readable
-                           -- 讀めない
-                           $ abort Forbidden [] Nothing
+         perms ← liftIO $ getPermissions path
+         unless (readable perms)
+             $ abort
+             $ mkAbortion Forbidden [] Nothing
 
-                -- 讀める
-                tag      <- liftIO $ generateETagFromFile path
-                lastMod  <- liftIO $ getModificationTime path
-                foundEntity tag lastMod
+         lastMod ← liftIO $ getLastModified path
+         foundTimeStamp lastMod
 
-                -- MIME Type を推定
-                conf <- getConfig
-                case guessTypeByFileName (cnfExtToMIMEType conf) path of
-                  Nothing   -> return ()
-                  Just mime -> setContentType mime
+         conf ← getConfig
+         case guessTypeByFileName (cnfExtToMIMEType conf) path of
+           Nothing   → setContentType octetStream
+           Just mime → setContentType mime
 
-                -- 實際にファイルを讀んで送る
-                (liftIO $ B.readFile path) >>= outputBS
-           else
-             foundNoEntity Nothing
+         when sendContent
+             $ liftIO (LBS.readFile path) ≫= putChunks
 
+-- | @'staticDir' dir@ is a 'Resource' which maps all files in @dir@
+-- and its subdirectories on the filesystem to the
+-- 'Network.HTTP.Lucu.Resource.Tree.ResTree'.
+--
+-- Note that 'staticDir' currently doesn't have a directory-listing
+-- capability. Requesting the content of a directory will end up being
+-- replied with /403 Forbidden/.
+staticDir ∷ FilePath → Resource
+staticDir path
+    = emptyResource {
+        resIsGreedy = True
+      , resGet      = Just $ handleStaticDir True  path
+      , resHead     = Just $ handleStaticDir False path
+      }
+
+-- TODO: implement directory listing.
+handleStaticDir ∷ Bool → FilePath → Rsrc ()
+handleStaticDir sendContent basePath
+    = do extraPath ← getPathInfo
+         securityCheck extraPath
+         let path = basePath </> joinPath (map dec8 extraPath)
+         handleStaticFile sendContent path
+    where
+      dec8 ∷ ByteString → String
+      dec8 = T.unpack ∘ T.decodeUtf8
 
--- inode-size-lastmod
-generateETagFromFile :: FilePath -> IO ETag
-generateETagFromFile path
-    = do stat <- getFileStatus path
-         let inode   = fromEnum $ fileID   stat
-             size    = fromEnum $ fileSize stat
-             lastmod = fromEnum $ modificationTime stat
-         return $ strongETag $ printf "%x-%x-%x" inode size lastmod
+securityCheck ∷ (Eq s, Show s, IsString s, Monad m) ⇒ [s] → m ()
+securityCheck pathElems
+    = when (any (≡ "..") pathElems)
+          $ fail ("security error: " ⧺ show pathElems)