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 8f93513659affc2dbf5c0ddbe31fe27eab6929ae..90cdcb0fa22d65d12e8ce1f08c6940551a142f6c 100644 (file)
--- a/Network/HTTP/Lucu/StaticFile.hs
+++ b/Network/HTTP/Lucu/StaticFile.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE
     DoAndIfThenElse
   , OverloadedStrings
+  , QuasiQuotes
   , UnicodeSyntax
   #-}
 -- | Handling static files on the filesystem.
@@ -17,17 +18,21 @@ import Control.Monad
 import Control.Monad.Unicode
 import Control.Monad.Trans
 import qualified Data.Ascii as A
-import qualified Data.ByteString.Lazy.Char8 as B
+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
+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.Tree
+import Network.HTTP.Lucu.Resource.Internal
 import Network.HTTP.Lucu.Response
 import Prelude.Unicode
 import System.FilePath
@@ -43,21 +48,23 @@ staticFile path
       }
 
 octetStream ∷ MIMEType
-octetStream = mkMIMEType "application" "octet-stream"
+octetStream = [mimeType| application/octet-stream |]
 
 handleStaticFile ∷ Bool → FilePath → Resource ()
 handleStaticFile sendContent path
     = do exists ← liftIO $ fileExist path
          unless exists
-             $ foundNoEntity Nothing
+             foundNoEntity'
 
          readable ← liftIO $ fileAccess path True False False
          unless readable
-             $ abort Forbidden [] Nothing
+             $ abort
+             $ mkAbortion Forbidden [] Nothing
 
          stat ← liftIO $ getFileStatus path
          when (isDirectory stat)
-             $ abort Forbidden [] Nothing
+             $ abort
+             $ mkAbortion Forbidden [] Nothing
 
          tag  ← liftIO $ generateETagFromFile path
          let lastMod = posixSecondsToUTCTime
@@ -72,7 +79,7 @@ handleStaticFile sendContent path
            Just mime → setContentType mime
 
          when sendContent
-             $ liftIO (B.readFile path) ≫= output
+             $ 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
@@ -102,7 +109,8 @@ generateETagFromFile path
          return $ strongETag tag
 
 -- | @'staticDir' dir@ is a 'ResourceDef' which maps all files in
--- @dir@ and its subdirectories on the filesystem to the 'ResTree'.
+-- @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
@@ -115,15 +123,18 @@ staticDir 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 T.unpack extraPath)
-
+         let path = basePath </> joinPath (map dec8 extraPath)
          handleStaticFile sendContent path
     where
-      securityCheck pathElems
-          = when (any (≡ "..") pathElems)
-                $ fail ("security error: " ⧺ show pathElems)
--- TODO: implement directory listing.
+      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)