New module: Network.HTTP.Lucu.MIMEType.TH

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

diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs
index cbbed1e8e44bdbb44f88ef0a3019ad5137b67217..90cdcb0fa22d65d12e8ce1f08c6940551a142f6c 100644 (file)
--- a/Network/HTTP/Lucu/StaticFile.hs
+++ b/Network/HTTP/Lucu/StaticFile.hs
@@ -1,13 +1,140 @@
+{-# LANGUAGE
+    DoAndIfThenElse
+  , OverloadedStrings
+  , QuasiQuotes
+  , UnicodeSyntax
+  #-}
+-- | Handling static files on the filesystem.
 module Network.HTTP.Lucu.StaticFile
-    (
+    ( staticFile
+    , staticDir
+
+    , generateETagFromFile
     )
     where
+import qualified Blaze.ByteString.Builder.ByteString as BB
+import qualified Blaze.Text.Int as BT
+import Control.Monad
+import Control.Monad.Unicode
+import Control.Monad.Trans
+import qualified Data.Ascii as A
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as LBS
+import Data.Monoid.Unicode
+import Data.String
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import Data.Time.Clock.POSIX
+import Network.HTTP.Lucu.Abortion
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.ETag
+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 Prelude.Unicode
+import System.FilePath
+import System.Posix.Files
 
-
-staticFile :: FilePath -> ResourceDef
+-- | @'staticFile' fpath@ is a '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
+    = emptyResource {
+        resGet  = Just $ handleStaticFile True  path
+      , resHead = Just $ handleStaticFile False path
+      }
+
+octetStream ∷ MIMEType
+octetStream = [mimeType| application/octet-stream |]
+
+handleStaticFile ∷ Bool → FilePath → Resource ()
+handleStaticFile sendContent path
+    = do exists ← liftIO $ fileExist path
+         unless exists
+             foundNoEntity'
+
+         readable ← liftIO $ fileAccess path True False False
+         unless readable
+             $ abort
+             $ mkAbortion Forbidden [] Nothing
+
+         stat ← liftIO $ getFileStatus path
+         when (isDirectory stat)
+             $ abort
+             $ mkAbortion Forbidden [] Nothing
+
+         tag  ← liftIO $ generateETagFromFile path
+         let lastMod = posixSecondsToUTCTime
+                       $ fromRational
+                       $ toRational
+                       $ modificationTime stat
+         foundEntity tag lastMod
+
+         conf ← getConfig
+         case guessTypeByFileName (cnfExtToMIMEType conf) path of
+           Nothing   → setContentType octetStream
+           Just mime → setContentType mime
+
+         when sendContent
+             $ liftIO (LBS.readFile path) ≫= putChunks
+
+-- |@'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 strictly strong ETag from a
+-- file as 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
+    = do stat ← getFileStatus path
+         let inode   = fileID   stat
+             size    = fileSize stat
+             lastMod = fromEnum $ modificationTime stat
+             tag     = A.fromAsciiBuilder
+                       $ A.unsafeFromBuilder
+                       $ BT.integral inode
+                       ⊕ BB.fromByteString "-"
+                       ⊕ BT.integral size
+                       ⊕ BB.fromByteString "-"
+                       ⊕ BT.integral lastMod
+         return $ strongETag tag
+
+-- | @'staticDir' dir@ is a 'ResourceDef' 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 → ResourceDef
+staticDir path
+    = emptyResource {
+        resIsGreedy = True
+      , resGet      = Just $ handleStaticDir True  path
+      , resHead     = Just $ handleStaticDir False path
+      }
+
+-- TODO: implement directory listing.
+handleStaticDir ∷ Bool → FilePath → Resource ()
+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
+
+securityCheck ∷ (Eq s, Show s, IsString s, Monad m) ⇒ [s] → m ()
+securityCheck pathElems
+    = when (any (≡ "..") pathElems)
+          $ fail ("security error: " ⧺ show pathElems)