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 cbbed1e8e44bdbb44f88ef0a3019ad5137b67217..5b5eb9734e3a68441516f36a86ada99269ea7888 100644 (file)
--- a/Network/HTTP/Lucu/StaticFile.hs
+++ b/Network/HTTP/Lucu/StaticFile.hs
@@ -1,13 +1,102 @@
+{-# LANGUAGE
+    DoAndIfThenElse
+  , OverloadedStrings
+  , QuasiQuotes
+  , UnicodeSyntax
+  #-}
+-- | Handling static files on the filesystem.
 module Network.HTTP.Lucu.StaticFile
-    (
+    ( 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
 
-
-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 $ 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 → Rsrc ()
+handleStaticFile sendContent path
+    = do isDir ← liftIO $ doesDirectoryExist path
+         when isDir
+             $ abort
+             $ mkAbortion Forbidden [] Nothing
+
+         isFile ← liftIO $ doesFileExist path
+         unless isFile
+             foundNoEntity'
+
+         perms ← liftIO $ getPermissions path
+         unless (readable perms)
+             $ abort
+             $ mkAbortion Forbidden [] Nothing
+
+         lastMod ← liftIO $ getLastModified path
+         foundTimeStamp lastMod
+
+         conf ← getConfig
+         case guessTypeByFileName (cnfExtToMIMEType conf) path of
+           Nothing   → setContentType octetStream
+           Just mime → setContentType mime
+
+         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
+
+securityCheck ∷ (Eq s, Show s, IsString s, Monad m) ⇒ [s] → m ()
+securityCheck pathElems
+    = when (any (≡ "..") pathElems)
+          $ fail ("security error: " ⧺ show pathElems)